Codebase list libtext-mediawikiformat-perl / upstream/1.04
Imported Upstream version 1.04 Axel Beckert 8 years ago
26 changed file(s) with 1629 addition(s) and 1758 deletion(s). Raw diff Collapse all Expand all
+0
-58
Build.PL less more
0 #! perl
1
2 use Module::Build;
3
4 my $class = Module::Build->subclass(
5 class => 'Module::Build::FilterTests',
6 code => <<'END_HERE',
7
8 use File::Glob;
9 use File::Spec::Functions;
10
11 sub ACTION_disttest
12 {
13 my $self = shift;
14 local $ENV{PERL_RUN_ALL_TESTS} = 1;
15 $self->SUPER::ACTION_disttest (@_);
16 }
17
18 sub find_test_files
19 {
20 my $self = shift;
21 my $tests = $self->SUPER::find_test_files (@_);
22
23 return $tests unless $ENV{PERL_RUN_ALL_TESTS};
24
25 my $test_pattern = catfile (qw(t developer *.t));
26 push @$tests, File::Glob::bsd_glob( $test_pattern );
27 return $tests;
28 }
29 END_HERE
30 );
31
32 my $build = $class->new(
33 license => 'perl',
34 module_name => 'Text::MediawikiFormat',
35 requires =>
36 {
37 'Scalar::Util' => '1.14',
38 'URI' => '',
39 'URI::Escape' => '',
40 'version' => '0.74',
41 },
42 recommends =>
43 {
44 'HTML::Parser' => '',
45 'HTML::Tagset' => '',
46 },
47 build_requires =>
48 {
49 'Test::More' => 0.30,
50 'Test::NoWarnings' => 0,
51 'Test::Warn' => 0,
52 },
53 create_makefile_pl => 'traditional',
54 sign => '1',
55 );
56
57 $build->create_build_script();
+24
-7
Changes less more
00 Revision history for Text-MediawikiFormat
11
2 1.0 June 19, 2008
2 1.04 2014.12.01
3 - Add CGI as prerequisite.
4 -
5
6 1.03 2014.11.20
7 - Move package Text::MediawikiFormat::Block to its own file.
8
9 1.02 2014.11.20
10 - New maintainer
11 - Add GitHub links to META files
12 - Add license to META files
13 - Remove Build.PL and only use Makefile.PL
14
15 1.01 2014.09.14
16 - Unofficial release.
17 - Fix failing test.
18
19 1.0 2008.06.19
320 - Empty tags are handled like they should be. This should make it
421 easier to implement <references /> & <ref name="previous" /> (fixes
522 rt.cpan.org #25386).
1431 utf-8 in the options hash (fixes rt.cpan.org #26880).
1532 - Documentation fixes.
1633
17 0.06 June 17, 2008
34 0.06 2008.06.17
1835 - Tests skip HTML processing when HTML::Parser and HTML::Tagset are
1936 not installed.
2037 - format() actually processes the options hash.
2138 - Change _clone to Return arrays and a deep copy of hashes.
2239 Rather than a copy of arrays.
2340
24 0.05 September 28, 2006
41 0.05 2006.09.28
2542 - Remove the <> when linkifying <http://absolute.link>.
2643
27 0.04 September 27, 2006
44 0.04 2006.09.27
2845 - Process absolute links more robustly.
2946
30 0.03 September 27, 2006
47 0.03 2006.09.27
3148 - Default to absolute_links => 1.
3249 - Prefer "our" to "use vars".
3350
34 0.02 September 26, 2006
51 0.02 2006.09.26
3552 - Improved documentation.
3653 - Defaults to Mediawiki behaviors.
3754
38 0.01 September 20, 2006
55 0.01 2006.0.20
3956 - Avoid applying wikification when block level allowed html elements
4057 are present, when process_html option is set.
4158 - content of list items is now formatted by default.
+2
-4
MANIFEST less more
00 ARTISTIC
1 Build.PL
21 Changes
32 GPL
43 MANIFEST
76 README
87 lib/Text/MediawikiFormat.pm
98 lib/Text/MediawikiFormat/Blocks.pm
9 lib/Text/MediawikiFormat/Block.pm
1010 t/Wiki.t
1111 t/absolute_links.t
1212 t/base.t
1313 t/bugs.t
14 t/developer/0-signature.t
1514 t/developer/pod.t
1615 t/developer/pod-coverage.t
1716 t/embedded-links.t
2423 t/merge-hash.t
2524 t/tag-override-use-as.t
2625 t/tag-override.t
27 SIGNATURE Added here by Module::Build
28 SIGNATURE Added here by Module::Build
26 META.json Module JSON meta-data (added by MakeMaker)
+61
-0
META.json less more
0 {
1 "abstract" : "unknown",
2 "author" : [
3 "unknown"
4 ],
5 "dynamic_config" : 1,
6 "generated_by" : "ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.142060",
7 "license" : [
8 "perl_5"
9 ],
10 "meta-spec" : {
11 "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
12 "version" : "2"
13 },
14 "name" : "Text-MediawikiFormat",
15 "no_index" : {
16 "directory" : [
17 "t",
18 "inc"
19 ]
20 },
21 "prereqs" : {
22 "build" : {
23 "requires" : {
24 "ExtUtils::MakeMaker" : "0"
25 }
26 },
27 "configure" : {
28 "requires" : {
29 "ExtUtils::MakeMaker" : "0"
30 }
31 },
32 "runtime" : {
33 "requires" : {
34 "CGI" : "0",
35 "HTML::Parser" : "0",
36 "HTML::Tagset" : "0",
37 "Scalar::Util" : "1.14",
38 "Test::More" : "0.3",
39 "Test::NoWarnings" : "0",
40 "Test::Warn" : "0",
41 "URI" : "0",
42 "URI::Escape" : "0",
43 "version" : "0.74"
44 }
45 }
46 },
47 "release_status" : "stable",
48 "resources" : {
49 "bugtracker" : {
50 "web" : "http://github.com/szabgab/Text-MediawikiFormat/issues"
51 },
52 "repository" : {
53 "type" : "git",
54 "url" : "http://github.com/szabgab/Text-MediawikiFormat.git",
55 "web" : "http://github.com/szabgab/Text-MediawikiFormat",
56 "x_license" : "http://dev.perl.org/licenses/"
57 }
58 },
59 "version" : "1.04"
60 }
+31
-29
META.yml less more
00 ---
1 abstract: unknown
2 author:
3 - unknown
4 build_requires:
5 ExtUtils::MakeMaker: '0'
6 configure_requires:
7 ExtUtils::MakeMaker: '0'
8 dynamic_config: 1
9 generated_by: 'ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.142060'
10 license: perl
11 meta-spec:
12 url: http://module-build.sourceforge.net/META-spec-v1.4.html
13 version: '1.4'
114 name: Text-MediawikiFormat
2 version: v1.0
3 author: []
4 abstract: Translate Wiki markup into other text formats
5 license: perl
15 no_index:
16 directory:
17 - t
18 - inc
19 requires:
20 CGI: '0'
21 HTML::Parser: '0'
22 HTML::Tagset: '0'
23 Scalar::Util: '1.14'
24 Test::More: '0.3'
25 Test::NoWarnings: '0'
26 Test::Warn: '0'
27 URI: '0'
28 URI::Escape: '0'
29 version: '0.74'
630 resources:
7 license: http://dev.perl.org/licenses/
8 requires:
9 Scalar::Util: 1.14
10 URI: ''
11 URI::Escape: ''
12 version: 0.74
13 build_requires:
14 Test::More: 0.3
15 Test::NoWarnings: 0
16 Test::Warn: 0
17 recommends:
18 HTML::Parser: ''
19 HTML::Tagset: ''
20 provides:
21 Text::MediawikiFormat:
22 file: lib/Text/MediawikiFormat.pm
23 version: v1.0
24 Text::MediawikiFormat::Block:
25 file: lib/Text/MediawikiFormat/Blocks.pm
26 Text::MediawikiFormat::Blocks:
27 file: lib/Text/MediawikiFormat/Blocks.pm
28 generated_by: Module::Build version 0.2808
29 meta-spec:
30 url: http://module-build.sourceforge.net/META-spec-v1.2.html
31 version: 1.2
31 bugtracker: http://github.com/szabgab/Text-MediawikiFormat/issues
32 repository: http://github.com/szabgab/Text-MediawikiFormat.git
33 version: '1.04'
+41
-19
Makefile.PL less more
0 # Note: this file was auto-generated by Module::Build::Compat version 0.03
10 use ExtUtils::MakeMaker;
2 WriteMakefile
3 (
4 'NAME' => 'Text::MediawikiFormat',
5 'VERSION_FROM' => 'lib/Text/MediawikiFormat.pm',
6 'PREREQ_PM' => {
7 'Scalar::Util' => '1.14',
8 'Test::More' => '0.3',
9 'Test::NoWarnings' => '0',
10 'Test::Warn' => '0',
11 'URI' => '',
12 'URI::Escape' => '',
13 'version' => '0.74'
14 },
15 'INSTALLDIRS' => 'site',
16 'EXE_FILES' => [],
17 'PL_FILES' => {}
18 )
19 ;
1 my %conf = (
2 'NAME' => 'Text::MediawikiFormat',
3 'VERSION_FROM' => 'lib/Text/MediawikiFormat.pm',
4 'PREREQ_PM' => {
5 'CGI' => '0',
6 'Scalar::Util' => '1.14',
7 'Test::More' => '0.3',
8 'Test::NoWarnings' => '0',
9 'Test::Warn' => '0',
10 'URI' => '0',
11 'URI::Escape' => '0',
12 'version' => '0.74',
13 'HTML::Parser' => '0', # recommended only
14 'HTML::Tagset' => '0', # recommented only
15
16 },
17 'INSTALLDIRS' => 'site',
18 'LICENSE' => 'perl',
19 'EXE_FILES' => [],
20 'PL_FILES' => {}
21 );
22
23 if ( eval { ExtUtils::MakeMaker->VERSION(6.46) } ) {
24 $conf{META_MERGE} = {
25 'meta-spec' => { version => 2 },
26 resources => {
27 repository => {
28 type => 'git',
29 url => 'http://github.com/szabgab/Text-MediawikiFormat.git',
30 web => 'http://github.com/szabgab/Text-MediawikiFormat',
31 license => 'http://dev.perl.org/licenses/',
32 },
33 bugtracker => {
34 web => 'http://github.com/szabgab/Text-MediawikiFormat/issues',
35 },
36 },
37 };
38 }
39
40 WriteMakefile(%conf);
41
+0
-50
SIGNATURE less more
0 This file contains message digests of all files listed in MANIFEST,
1 signed via the Module::Signature module, version 0.55.
2
3 To verify the content in this distribution, first make sure you have
4 Module::Signature installed, then type:
5
6 % cpansign -v
7
8 It will check each file's integrity, as well as the signature's
9 validity. If "==> Signature verified OK! <==" is not displayed,
10 the distribution may already have been compromised, and you should
11 not run its Makefile.PL or Build.PL.
12
13 -----BEGIN PGP SIGNED MESSAGE-----
14 Hash: SHA1
15
16 SHA1 de99730c9cff5401331cc9b10da8fffc2607119e ARTISTIC
17 SHA1 22316eae2efc4afadca11b79369f9e173d6039b1 Build.PL
18 SHA1 205fdf6b110d7a4ab9935d5c0ad4bfcff2294e3a Changes
19 SHA1 2d29c273fda30310211bbf6a24127d589be09b6c GPL
20 SHA1 eccb0808083e42742ab218aade252010ec49a567 MANIFEST
21 SHA1 32787552984162e780b38633dd67f4809fb5e992 META.yml
22 SHA1 c37ec8e62f2d6b0fffe4b4a73c2bdf3c3f2def3b Makefile.PL
23 SHA1 32770eb383f51fec27a092d2c39f0b1c302df6e6 README
24 SHA1 ac1b2db56ba408051f88f7515b5d041400547b0f lib/Text/MediawikiFormat.pm
25 SHA1 fd66bd52dab924fbdf8185b56b4b0f835cba8b44 lib/Text/MediawikiFormat/Blocks.pm
26 SHA1 645310aa31699333b7d7bfaa9da48e7a8fdbb8f7 t/Wiki.t
27 SHA1 b617b7515b2c9cc7a194693af3f002b7665c943d t/absolute_links.t
28 SHA1 d6b24c5b497740c653882d6f3a691b7e51ea8f02 t/base.t
29 SHA1 d7db75f52a1631a3f78ceb00ece490f1f0d6c6b1 t/bugs.t
30 SHA1 e7fbd29bd994639e82a480ca7668208c84faf780 t/developer/0-signature.t
31 SHA1 9f8e6742d15fc02f70fea8c7883e534b5ab0027e t/developer/pod-coverage.t
32 SHA1 0190346d7072d458c8a10a45c19f86db641dcc48 t/developer/pod.t
33 SHA1 c09a0d0ba5a0b9c152a1f93315b9c49fcfbd865c t/embedded-links.t
34 SHA1 8f75e7cd212a52a42eea81ed150fe5450c70e87a t/explicit.t
35 SHA1 bbc7124baf9098da6c2dcf89f2a3284683413b6a t/implicit.t
36 SHA1 6b7053b05703eb121a6b45452dca7372a5ae4d7b t/kake.t
37 SHA1 784b48b387dd561d52de82cd2b94af222c61d26d t/lists-nested.t
38 SHA1 dcacb77dfbcb5a2036f5aba0aa5aabf0a1082098 t/lists-no-indent.t
39 SHA1 29d22f52586b606688d50640d15266439d74eb93 t/lists.t
40 SHA1 e8317c38218cf0420d4cc4c2fb66cb50c3caed99 t/merge-hash.t
41 SHA1 1a5a502110014d7694d78dad6fdd8d182bd16eb9 t/tag-override-use-as.t
42 SHA1 e8161481a91f596eaa2bf6852cadb4ac0b9379df t/tag-override.t
43 -----BEGIN PGP SIGNATURE-----
44 Version: GnuPG v1.4.2.2 (GNU/Linux)
45
46 iD8DBQFIWr9dLD1OTBfyMaQRAhnjAJ91HRbRtBZOsbp7PCzqw+NYnxaRKwCffQAA
47 ujduk8fkZPX40g58mtBNZlY=
48 =gfGy
49 -----END PGP SIGNATURE-----
+133
-0
lib/Text/MediawikiFormat/Block.pm less more
0 package Text::MediawikiFormat::Block;
1
2 use strict;
3 use warnings::register;
4
5 use Scalar::Util qw( blessed reftype );
6
7 our $VERSION = '1.04';
8
9 sub new {
10 my ( $class, %args ) = @_;
11
12 $args{text} = $class->arg_to_ref( delete $args{text} || '' );
13 $args{args} = [ $class->arg_to_ref( delete $args{args} || [] ) ];
14
15 bless \%args, $class;
16 }
17
18 sub arg_to_ref {
19 my ( $class, $value ) = @_;
20 return $value if ( reftype($value) || '' ) eq 'ARRAY';
21 return [$value];
22 }
23
24 sub shift_args {
25 my $self = shift;
26 my $args = shift @{ $self->{args} };
27 return wantarray ? @$args : $args;
28 }
29
30 sub all_args {
31 my $args = $_[0]{args};
32 return wantarray ? @$args : $args;
33 }
34
35 sub text {
36 my $text = $_[0]{text};
37 return wantarray ? @$text : $text;
38 }
39
40 sub add_text {
41 my $self = shift;
42 push @{ $self->{text} }, @_;
43 }
44
45 sub formatted_text {
46 my $self = shift;
47 return map { blessed($_) ? $_ : $self->formatter($_) } $self->text();
48 }
49
50 sub formatter {
51 my ( $self, $line ) = @_;
52 Text::MediawikiFormat::format_line( $line, $self->tags(), $self->opts() );
53 }
54
55 sub add_args {
56 my $self = shift;
57 push @{ $self->{args} }, @_;
58 }
59
60 {
61 no strict 'refs';
62 for my $attribute (qw( level opts tags type )) {
63 *{$attribute} = sub { $_[0]{$attribute} };
64 }
65 }
66
67 sub merge {
68 my ( $self, $next_block ) = @_;
69
70 return $next_block unless $self->type() eq $next_block->type();
71 return $next_block unless $self->level() == $next_block->level();
72
73 $self->add_text( $next_block->text() );
74 $self->add_args( $next_block->all_args() );
75 return;
76 }
77
78 sub nests {
79 my ( $self, $maynest ) = @_;
80 my $tags = $self->{tags};
81
82 return
83 exists $tags->{nests}{ $self->type() }
84 && exists $tags->{nests}{ $maynest->type() }
85 && $self->level()
86 < $maynest->level()
87
88 # <nowiki> tags nest anywhere, regardless of level and parent
89 || exists $tags->{nests_anywhere}{ $maynest->type() };
90 }
91
92 sub nest {
93 my ( $self, $next_block ) = @_;
94
95 return unless $next_block = $self->merge($next_block);
96 return $next_block unless $self->nests($next_block);
97
98 # if there's a nested block at the end, maybe it can nest too
99 my $last_item = ( $self->text() )[-1];
100 return $last_item->nest($next_block) if blessed($last_item);
101
102 $self->add_text($next_block);
103 return;
104 }
105
106 1;
107
108 __END__
109
110 =head1 NAME
111
112 Text::MediawikiFormat::Block - blocktype for Text::MediawikiFormat
113
114 =head1 SYNOPSIS
115
116 None. Use L<Text::MediawikiFormat> as the public interface, unless you want to
117 create your own block type. See also L<Text::MediawikiFormat::Blocks>.
118
119 =head1 AUTHOR
120
121 chromatic, C<< chromatic at wgz dot org >>
122
123 =head1 BUGS
124
125 No known bugs.
126
127 =head1 COPYRIGHT
128
129 Copyright (c) 2006, chromatic. Some rights reserved.
130
131 This module is free software; you can use, redistribute, and modify it under
132 the same terms as Perl 5.8.x.
+9
-122
lib/Text/MediawikiFormat/Blocks.pm less more
22 use strict;
33 use warnings::register;
44
5 sub import
6 {
5 use Text::MediawikiFormat::Block;
6
7 our $VERSION = '1.04';
8
9 sub import {
710 my $caller = caller();
811 no strict 'refs';
9 *{ $caller . '::new_block' } = sub
10 {
12 *{ $caller . '::new_block' } = sub {
1113 my $type = shift;
1214 my $class = "Text::MediawikiFormat::Block::$type";
13
14 *{ $class . '::ISA' } = [ 'Text::MediawikiFormat::Block' ]
15 unless $class->can( 'new' );
15
16 *{ $class . '::ISA' } = ['Text::MediawikiFormat::Block']
17 unless $class->can('new');
1618
1719 return $class->new( type => $type, @_ );
1820 };
19 }
20
21 package Text::MediawikiFormat::Block;
22
23 use Scalar::Util qw( blessed reftype );
24
25 sub new
26 {
27 my ($class, %args) = @_;
28
29 $args{text} = $class->arg_to_ref (delete $args{text} || '');
30 $args{args} = [$class->arg_to_ref (delete $args{args} || [])];
31
32 bless \%args, $class;
33 }
34
35 sub arg_to_ref
36 {
37 my ($class, $value) = @_;
38 return $value if ( reftype( $value ) || '' ) eq 'ARRAY';
39 return [ $value ];
40 }
41
42 sub shift_args
43 {
44 my $self = shift;
45 my $args = shift @{ $self->{args} };
46 return wantarray ? @$args : $args;
47 }
48
49 sub all_args
50 {
51 my $args = $_[0]{args};
52 return wantarray ? @$args : $args;
53 }
54
55 sub text
56 {
57 my $text = $_[0]{text};
58 return wantarray ? @$text : $text;
59 }
60
61 sub add_text
62 {
63 my $self = shift;
64 push @{ $self->{text} }, @_;
65 }
66
67 sub formatted_text
68 {
69 my $self = shift;
70 return map
71 {
72 blessed( $_ ) ? $_ : $self->formatter( $_ )
73 } $self->text();
74 }
75
76 sub formatter
77 {
78 my ($self, $line) = @_;
79 Text::MediawikiFormat::format_line ($line, $self->tags(),
80 $self->opts());
81 }
82
83 sub add_args
84 {
85 my $self = shift;
86 push @{ $self->{args} }, @_;
87 }
88
89 {
90 no strict 'refs';
91 for my $attribute (qw( level opts tags type ))
92 {
93 *{ $attribute } = sub { $_[0]{$attribute} };
94 }
95 }
96
97 sub merge
98 {
99 my ($self, $next_block) = @_;
100
101 return $next_block unless $self->type() eq $next_block->type();
102 return $next_block unless $self->level() == $next_block->level();
103
104 $self->add_text( $next_block->text() );
105 $self->add_args( $next_block->all_args() );
106 return;
107 }
108
109 sub nests
110 {
111 my ($self, $maynest) = @_;
112 my $tags = $self->{tags};
113
114 return exists $tags->{nests}{$self->type()}
115 && exists $tags->{nests}{$maynest->type()}
116 && $self->level() < $maynest->level()
117 # <nowiki> tags nest anywhere, regardless of level and parent
118 || exists $tags->{nests_anywhere}{$maynest->type()};
119 }
120
121 sub nest
122 {
123 my ($self, $next_block) = @_;
124
125 return unless $next_block = $self->merge ($next_block);
126 return $next_block unless $self->nests ($next_block);
127
128 # if there's a nested block at the end, maybe it can nest too
129 my $last_item = ( $self->text() )[-1];
130 return $last_item->nest( $next_block ) if blessed( $last_item );
131
132 $self->add_text( $next_block );
133 return;
13421 }
13522
13623 1;
+908
-986
lib/Text/MediawikiFormat.pm less more
88
99 =head1 VERSION
1010
11 Version 1.0
11 Version 1.04
1212
1313 =cut
1414
15 use vars qw($VERSION);
16 use version; $VERSION = qv('1.0');
15 our $VERSION = '1.04';
1716
1817 =head1 SYNOPSIS
1918
20 use Text::MediawikiFormat 'wikiformat';
21 my $html = wikiformat ($raw);
22 my $text = wikiformat ($raw, {}, {implicit_links => 1});
19 use Text::MediawikiFormat 'wikiformat';
20 my $html = wikiformat ($raw);
21 my $text = wikiformat ($raw, {}, {implicit_links => 1});
2322
2423 =head1 DESCRIPTION
2524
5352 use URI::Escape qw(uri_escape uri_escape_utf8);
5453
5554 use vars qw($missing_html_packages %tags %opts %merge_matrix
56 $uric $uricCheat $uriCruft);
57
58 BEGIN
59 {
60 # Try to load optional HTML packages, recording any errors.
61 eval {require HTML::Parser};
62 $missing_html_packages = $@;
63 eval {require HTML::Tagset};
64 $missing_html_packages .= $@;
65 }
66
67
55 $uric $uricCheat $uriCruft);
56
57 BEGIN {
58 # Try to load optional HTML packages, recording any errors.
59 eval { require HTML::Parser };
60 $missing_html_packages = $@;
61 eval { require HTML::Tagset };
62 $missing_html_packages .= $@;
63 }
6864
6965 ###
7066 ### Defaults
7167 ###
72 %tags =
73 (
74 indent => qr/^(?:[:*#;]*)(?=[:*#;])/,
75 link => \&_make_html_link,
76 strong => sub {"<strong>$_[0]</strong>"},
77 emphasized => sub {"<em>$_[0]</em>"},
78 strong_tag => qr/'''(.+?)'''/,
79 emphasized_tag => qr/''(.+?)''/,
80
81 code => ['<pre>', "</pre>\n", '', "\n"],
82 line => ['', '', '<hr />', "\n"],
83 paragraph => ["<p>", "</p>\n", '', "\n", 1],
84 paragraph_break => ['', '', '', "\n"],
85 unordered => ["<ul>\n", "</ul>\n", '<li>', "</li>\n"],
86 ordered => ["<ol>\n", "</ol>\n", '<li>', "</li>\n"],
87 definition => ["<dl>\n", "</dl>\n", \&_dl],
88 header => ['', "\n", \&_make_header],
89
90 blocks =>
91 {
92 code => qr/^ /,
93 header => qr/^(=+)\s*(.+?)\s*\1$/,
94 line => qr/^-{4,}$/,
95 ordered => qr/^#\s*/,
96 unordered => qr/^\*\s*/,
97 definition => qr/^([;:])\s*/,
98 paragraph => qr/^/,
99 paragraph_break => qr/^\s*$/,
100 },
101
102 indented => {map {$_ => 1} qw(ordered unordered definition)},
103 nests => {map {$_ => 1} qw(ordered unordered definition)},
104 nests_anywhere => {map {$_ => 1} qw(nowiki)},
105
106 blockorder => [qw(code header line ordered unordered definition
107 paragraph_break paragraph)],
108 implicit_link_delimiters
109 => qr!\b(?:[A-Z][a-z0-9]\w*){2,}!,
110 extended_link_delimiters
111 => qr!\[(?:\[[^][]*\]|[^][]*)\]!,
112
113 schemas => [qw(http https ftp mailto gopher)],
114
115 unformatted_blocks => [qw(header nowiki pre)],
116
117 allowed_tags => [#HTML
118 qw(b big blockquote br caption center cite code dd
119 div dl dt em font h1 h2 h3 h4 h5 h6 hr i li ol p
120 pre rb rp rt ruby s samp small strike strong sub
121 sup table td th tr tt u ul var),
122 # Mediawiki Specific
123 qw(nowiki),],
124 allowed_attrs => [qw(title align lang dir width height bgcolor),
125 qw(clear), # BR
126 qw(noshade), # HR
127 qw(cite), # BLOCKQUOTE, Q
128 qw(size face color), # FONT
129 # For various lists, mostly deprecated but safe
130 qw(type start value compact),
131 # Tables
132 qw(summary width border frame rules cellspacing
133 cellpadding valign char charoff colgroup col
134 span abbr axis headers scope rowspan colspan),
135 qw(id class name style), # For CSS
136 ],
137
138 _toc => [],
68 %tags = (
69 indent => qr/^(?:[:*#;]*)(?=[:*#;])/,
70 link => \&_make_html_link,
71 strong => sub {"<strong>$_[0]</strong>"},
72 emphasized => sub {"<em>$_[0]</em>"},
73 strong_tag => qr/'''(.+?)'''/,
74 emphasized_tag => qr/''(.+?)''/,
75
76 code => [ '<pre>', "</pre>\n", '', "\n" ],
77 line => [ '', '', '<hr />', "\n" ],
78 paragraph => [ "<p>", "</p>\n", '', "\n", 1 ],
79 paragraph_break => [ '', '', '', "\n" ],
80 unordered => [ "<ul>\n", "</ul>\n", '<li>', "</li>\n" ],
81 ordered => [ "<ol>\n", "</ol>\n", '<li>', "</li>\n" ],
82 definition => [ "<dl>\n", "</dl>\n", \&_dl ],
83 header => [ '', "\n", \&_make_header ],
84
85 blocks => {
86 code => qr/^ /,
87 header => qr/^(=+)\s*(.+?)\s*\1$/,
88 line => qr/^-{4,}$/,
89 ordered => qr/^#\s*/,
90 unordered => qr/^\*\s*/,
91 definition => qr/^([;:])\s*/,
92 paragraph => qr/^/,
93 paragraph_break => qr/^\s*$/,
94 },
95
96 indented => { map { $_ => 1 } qw(ordered unordered definition) },
97 nests => { map { $_ => 1 } qw(ordered unordered definition) },
98 nests_anywhere => { map { $_ => 1 } qw(nowiki) },
99
100 blockorder => [
101 qw(code header line ordered unordered definition
102 paragraph_break paragraph)
103 ],
104 implicit_link_delimiters => qr!\b(?:[A-Z][a-z0-9]\w*){2,}!,
105 extended_link_delimiters => qr!\[(?:\[[^][]*\]|[^][]*)\]!,
106
107 schemas => [qw(http https ftp mailto gopher)],
108
109 unformatted_blocks => [qw(header nowiki pre)],
110
111 allowed_tags => [ #HTML
112 qw(b big blockquote br caption center cite code dd
113 div dl dt em font h1 h2 h3 h4 h5 h6 hr i li ol p
114 pre rb rp rt ruby s samp small strike strong sub
115 sup table td th tr tt u ul var),
116
117 # Mediawiki Specific
118 qw(nowiki),
119 ],
120 allowed_attrs => [
121 qw(title align lang dir width height bgcolor),
122 qw(clear), # BR
123 qw(noshade), # HR
124 qw(cite), # BLOCKQUOTE, Q
125 qw(size face color), # FONT
126 # For various lists, mostly deprecated but safe
127 qw(type start value compact),
128
129 # Tables
130 qw(summary width border frame rules cellspacing
131 cellpadding valign char charoff colgroup col
132 span abbr axis headers scope rowspan colspan),
133 qw(id class name style), # For CSS
134 ],
135
136 _toc => [],
139137 );
140138
141 %opts =
142 (
143 extended => 1,
144 implicit_links => 0,
145 absolute_links => 1,
146 prefix => '',
147 process_html => 1,
148 charset => 'utf-8',
139 %opts = (
140 extended => 1,
141 implicit_links => 0,
142 absolute_links => 1,
143 prefix => '',
144 process_html => 1,
145 charset => 'utf-8',
149146 );
150147
151148 # Make sure import's argument hash contains an `as' entry. `as' defaults to
152149 # `wikiformat' when none is given.
153 sub _process_args
154 {
155 shift; # Class
150 sub _process_args {
151 shift; # Class
156152 return as => shift if @_ == 1;
157153 return as => 'wikiformat', @_;
158154 }
159155
160156 # Delete the options (prefix, extended, implicit_links, ...) from a hash,
161157 # returning a new hash with the deleted options.
162 sub _extract_opts
163 {
164 my %newopts;
165
166 for my $key (qw{prefix extended implicit_links absolute_links
167 process_html debug})
168 {
169 if (defined (my $val = delete $_[0]->{$key}))
158 sub _extract_opts {
159 my %newopts;
160
161 for my $key (
162 qw{prefix extended implicit_links absolute_links
163 process_html debug}
164 )
170165 {
171 $newopts{$key} = $val;
172 }
173 }
174
175 return \%newopts;
166 if ( defined( my $val = delete $_[0]->{$key} ) ) {
167 $newopts{$key} = $val;
168 }
169 }
170
171 return \%newopts;
176172 }
177173
178174 # Shamelessly ripped from Hash::Merge, which doesn't work in a threaded
179175 # environment with two threads trying to use different merge matrices.
180 %merge_matrix =
181 (
182 SCALAR =>
183 {
184 SCALAR => sub {return $_[0]},
185 ARRAY => sub {# Need to be able to replace scalar with array
186 # for extended_link_delimiters (could be array
187 # or regex).
188 return $_[0];},
189 HASH => sub {confess "Attempt to replace hash with scalar"
190 if defined $_[0];
191 return _clone ($_[1]);}
192 },
193
194 ARRAY =>
195 {
196 SCALAR => sub {# Need to be able to replace array with scalar
197 # for extended_link_delimiters (could be array
198 # or regex).
199 return _clone ($_[0]);},
200 ARRAY => sub {return _clone ($_[0]);},
201 HASH => sub {confess "Attempt to replace hash with array"}
202 },
203
204 HASH =>
205 {
206 SCALAR => sub {confess "Attempt to replace scalar with hash"},
207 ARRAY => sub {confess "Attempt to replace array with hash"},
208 HASH => sub {_merge_hash_elements ($_[0], $_[1])}
209 }
176 %merge_matrix = (
177 SCALAR => {
178 SCALAR => sub { return $_[0] },
179 ARRAY => sub { # Need to be able to replace scalar with array
180 # for extended_link_delimiters (could be array
181 # or regex).
182 return $_[0];
183 },
184 HASH => sub {
185 confess "Attempt to replace hash with scalar"
186 if defined $_[0];
187 return _clone( $_[1] );
188 }
189 },
190
191 ARRAY => {
192 SCALAR => sub { # Need to be able to replace array with scalar
193 # for extended_link_delimiters (could be array
194 # or regex).
195 return _clone( $_[0] );
196 },
197 ARRAY => sub { return _clone( $_[0] ); },
198 HASH => sub { confess "Attempt to replace hash with array" }
199 },
200
201 HASH => {
202 SCALAR => sub { confess "Attempt to replace scalar with hash" },
203 ARRAY => sub { confess "Attempt to replace array with hash" },
204 HASH => sub { _merge_hash_elements( $_[0], $_[1] ) }
205 }
210206 );
207
211208 # Return arrays and a deep copy of hashes.
212 sub _clone
213 {
214 my ($obj) = @_;
215 my $type;
216 if (!defined $obj) { # Perl 5.005 compatibility
217 $type = 'SCALAR';
218 } elsif (ref $obj eq 'HASH') {
219 $type = 'HASH';
220 } elsif (ref $obj eq 'ARRAY') {
221 $type = 'ARRAY';
222 } else {
223 $type = 'SCALAR';
224 }
225
226 return $obj if $type eq 'SCALAR';
227 return $obj if $type eq 'ARRAY';
228
229 my %copy;
230 foreach my $key (keys %$obj)
231 {
232 $copy{$key} = _clone ($obj->{$key});
233 }
234 return \%copy;
235 }
236 # This does a straight merge of hashes, delegating the merge-specific
209 sub _clone {
210 my ($obj) = @_;
211 my $type;
212 if ( !defined $obj ) { # Perl 5.005 compatibility
213 $type = 'SCALAR';
214 }
215 elsif ( ref $obj eq 'HASH' ) {
216 $type = 'HASH';
217 }
218 elsif ( ref $obj eq 'ARRAY' ) {
219 $type = 'ARRAY';
220 }
221 else {
222 $type = 'SCALAR';
223 }
224
225 return $obj if $type eq 'SCALAR';
226 return $obj if $type eq 'ARRAY';
227
228 my %copy;
229 foreach my $key ( keys %$obj ) {
230 $copy{$key} = _clone( $obj->{$key} );
231 }
232 return \%copy;
233 }
234
235 # This does a straight merge of hashes, delegating the merge-specific
237236 # work to '_merge_hashes'.
238 sub _merge_hash_elements
239 {
240 my ($left, $right) = @_;
241 die "Arguments for _merge_hash_elements must be hash references" unless
242 UNIVERSAL::isa ($left, 'HASH') && UNIVERSAL::isa ($right, 'HASH');
243
244 my %newhash;
245 foreach my $leftkey (keys %$left)
246 {
247 if (exists $right->{$leftkey})
248 {
249 $newhash{$leftkey} =
250 _merge_hashes ($left->{$leftkey}, $right->{$leftkey});
251 }
252 else
253 {
254 $newhash{$leftkey} = _clone ($left->{$leftkey});
255 }
256 }
257 foreach my $rightkey (keys %$right)
258 {
259 $newhash{$rightkey} = _clone ($right->{$rightkey})
260 if !exists $left->{$rightkey};
261 }
262 return \%newhash;
263 }
264 sub _merge_hashes
265 {
266 my ($left, $right) = @_;
267
268 # if one argument or the other is undefined or empty, don't worry about
269 # copying, just return the original.
270 return $right unless defined $left;
271 return $left unless defined $right;
272
273 # For the general use of this function, we want to create duplicates
274 # of all data that is merged.
275
276 my ($lefttype, $righttype);
277 if (ref $left eq 'HASH') {
278 $lefttype = 'HASH';
279 } elsif (ref $left eq 'ARRAY') {
280 $lefttype = 'ARRAY';
281 } else {
282 $lefttype = 'SCALAR';
283 }
284
285 if (ref $right eq 'HASH') {
286 $righttype = 'HASH';
287 } elsif (ref $right eq 'ARRAY') {
288 $righttype = 'ARRAY';
289 } else {
290 $righttype = 'SCALAR';
291 }
292
293 return $merge_matrix{$lefttype}->{$righttype} ($left, $right);
294 }
295
296 sub _require_html_packages
297 {
298 croak "$missing_html_packages\n"
299 . "HTML::Parser & HTML::Tagset is required for process_html\n"
300 if $missing_html_packages;
301 }
302
303 sub import
304 {
305 return unless @_ > 1;
306
307 my $class = shift;
308 my %args = $class->_process_args (@_);
309 my $name = delete $args{as};
310
311 my $caller = caller();
312 my $iopts = _merge_hashes _extract_opts (\%args), \%opts;
313 my $itags = _merge_hashes \%args, \%tags;
314
315 _require_html_packages
316 if $iopts->{process_html};
317
318 # Could verify ITAGS here via _check_blocks, but what if a user
319 # wants to add a block to block_order that they intend to override
320 # the implementation of with every call to format()?
321
322 no strict 'refs';
323 *{ $caller . "::" . $name } = sub
324 {
325 Text::MediawikiFormat::_format ($itags, $iopts, @_);
326 }
327 }
328
329
237 sub _merge_hash_elements {
238 my ( $left, $right ) = @_;
239 die "Arguments for _merge_hash_elements must be hash references"
240 unless UNIVERSAL::isa( $left, 'HASH' ) && UNIVERSAL::isa( $right, 'HASH' );
241
242 my %newhash;
243 foreach my $leftkey ( keys %$left ) {
244 if ( exists $right->{$leftkey} ) {
245 $newhash{$leftkey} = _merge_hashes( $left->{$leftkey}, $right->{$leftkey} );
246 }
247 else {
248 $newhash{$leftkey} = _clone( $left->{$leftkey} );
249 }
250 }
251 foreach my $rightkey ( keys %$right ) {
252 $newhash{$rightkey} = _clone( $right->{$rightkey} )
253 if !exists $left->{$rightkey};
254 }
255 return \%newhash;
256 }
257
258 sub _merge_hashes {
259 my ( $left, $right ) = @_;
260
261 # if one argument or the other is undefined or empty, don't worry about
262 # copying, just return the original.
263 return $right unless defined $left;
264 return $left unless defined $right;
265
266 # For the general use of this function, we want to create duplicates
267 # of all data that is merged.
268
269 my ( $lefttype, $righttype );
270 if ( ref $left eq 'HASH' ) {
271 $lefttype = 'HASH';
272 }
273 elsif ( ref $left eq 'ARRAY' ) {
274 $lefttype = 'ARRAY';
275 }
276 else {
277 $lefttype = 'SCALAR';
278 }
279
280 if ( ref $right eq 'HASH' ) {
281 $righttype = 'HASH';
282 }
283 elsif ( ref $right eq 'ARRAY' ) {
284 $righttype = 'ARRAY';
285 }
286 else {
287 $righttype = 'SCALAR';
288 }
289
290 return $merge_matrix{$lefttype}->{$righttype}( $left, $right );
291 }
292
293 sub _require_html_packages {
294 croak "$missing_html_packages\n" . "HTML::Parser & HTML::Tagset is required for process_html\n"
295 if $missing_html_packages;
296 }
297
298 sub import {
299 return unless @_ > 1;
300
301 my $class = shift;
302 my %args = $class->_process_args(@_);
303 my $name = delete $args{as};
304
305 my $caller = caller();
306 my $iopts = _merge_hashes _extract_opts( \%args ), \%opts;
307 my $itags = _merge_hashes \%args, \%tags;
308
309 _require_html_packages
310 if $iopts->{process_html};
311
312 # Could verify ITAGS here via _check_blocks, but what if a user
313 # wants to add a block to block_order that they intend to override
314 # the implementation of with every call to format()?
315
316 no strict 'refs';
317 *{ $caller . "::" . $name } = sub {
318 Text::MediawikiFormat::_format( $itags, $iopts, @_ );
319 }
320 }
330321
331322 =head1 FUNCTIONS
332323
346337 Wiki. The actual linked item itself will be appended to the prefix. This is
347338 useful to create full URIs:
348339
349 {prefix => 'http://example.com/wiki.pl?page='}
340 {prefix => 'http://example.com/wiki.pl?page='}
350341
351342 =item extended
352343
355346 URI titles are separated from their title with a space. These are valid
356347 extended links:
357348
358 [[A wiki page|and the title to display]]
359 [http://ximbiot.com URI title]
349 [[A wiki page|and the title to display]]
350 [http://ximbiot.com URI title]
360351
361352 Where the linking semantics of the destination format allow it, the result will
362353 display the title instead of the URI. In HTML terms, the title is the content
403394
404395 =cut
405396
406 sub format
407 {
408 _format (\%tags, \%opts, @_);
397 sub format {
398 _format( \%tags, \%opts, @_ );
409399 }
410400
411401 # Turn the contents after a ; or : into a dictionary list.
412402 # Using : without ; just looks like an indent.
413 sub _dl
414 {
415 #my ($line, $indent, $lead) = @_;
416 my ($term, $def);
417
418 if ($_[2] eq ';')
419 {
420 if ($_[0] =~ /^(.*?)\s+:\s+(.*)$/)
421 {
422 $term = $1;
423 $def = $2;
424 }
425 else
426 {
427 $term = $_[0];
428 }
429 }
430 else
431 {
432 $def = $_[0];
433 }
434
435 my @retval;
436 push @retval, "<dt>", $term, "</dt>\n" if defined $term;
437 push @retval, "<dd>", $def, "</dd>\n" if defined $def;
438 return @retval;
403 sub _dl {
404
405 #my ($line, $indent, $lead) = @_;
406 my ( $term, $def );
407
408 if ( $_[2] eq ';' ) {
409 if ( $_[0] =~ /^(.*?)\s+:\s+(.*)$/ ) {
410 $term = $1;
411 $def = $2;
412 }
413 else {
414 $term = $_[0];
415 }
416 }
417 else {
418 $def = $_[0];
419 }
420
421 my @retval;
422 push @retval, "<dt>", $term, "</dt>\n" if defined $term;
423 push @retval, "<dd>", $def, "</dd>\n" if defined $def;
424 return @retval;
439425 }
440426
441427 # Makes a regex out of the allowed schema array.
442 sub _make_schema_regex
443 {
444 my $re = join "|", map {qr/\Q$_\E/} @_;
445 return qr/(?:$re)/;
446 }
447
448 $uric = $URI::uric;
428 sub _make_schema_regex {
429 my $re = join "|", map {qr/\Q$_\E/} @_;
430 return qr/(?:$re)/;
431 }
432
433 $uric = $URI::uric;
449434 $uricCheat = $uric;
450435
451436 # We need to avoid picking up 'HTTP::Request::Common' so we have a
456441 $uriCruft = q/]),.!'";}/;
457442
458443 # escape a URI based on our charset.
459 sub _escape_uri
460 {
461 my ($opts, $uri) = @_;
462 confess "charset not initialized" unless $opts->{charset};
463 return uri_escape_utf8 $uri if $opts->{charset} =~ /^utf-?8$/i;
464 return uri_escape $uri;
444 sub _escape_uri {
445 my ( $opts, $uri ) = @_;
446 confess "charset not initialized" unless $opts->{charset};
447 return uri_escape_utf8 $uri if $opts->{charset} =~ /^utf-?8$/i;
448 return uri_escape $uri;
465449 }
466450
467451 # Turn [[Wiki Link|Title]], [URI Title], scheme:url, or StudlyCaps into links.
468 sub _make_html_link
469 {
470 my ($tag, $opts, $tags) = @_;
471
472 my ($class, $trailing) = ('', '');
473 my ($href, $title);
474 if ($tag =~ /^\[\[([^|#]*)(?:(#)([^|]*))?(?:(\|)(.*))?\]\]$/)
475 {
476 # Wiki link
477 $href = $opts->{prefix} . _escape_uri $opts, $1 if $1;
478 $href .= $2 . _escape_uri $opts, $3 if $2;
479
480 if ($4)
481 {
482 # Title specified explicitly.
483 if (length $5)
484 {
485 $title = $5;
486 }
487 else
488 {
489 # An empty title asks Mediawiki to strip any parens off the end
490 # of the node name.
491 $1 =~ /^([^(]*)(?:\s*\()?/;
492 $title = $1;
493 }
494 }
495 else
496 {
497 # Title defaults to the node name.
498 $title = $1;
499 }
500 }
501 elsif ($tag =~ /^\[(\S*)(?:(\s+)(.*))?\]$/)
502 {
503 # URI
504 $href = $1;
505 if ($2)
506 {
507 $title = $3;
508 }
509 else
510 {
511 $title = ++$opts->{_uri_refs};
512 }
513 $href =~ s/'/%27/g;
514 }
515 else
516 {
517 # Shouldn't be able to get here without either $opts->{absolute_links}
518 # or $opts->{implicit_links};
519 $tags->{_schema_regex} ||= _make_schema_regex @{$tags->{schemas}};
520 my $s = $tags->{_schema_regex};
521
522 if ($tag =~ /^$s:[$uricCheat][$uric]*$/)
523 {
524 # absolute link
525 $href = $&;
526 $trailing = $& if $href =~ s/[$uriCruft]$//;
527 $title = $href;
528 }
529 else
530 {
531 # StudlyCaps
532 $href = $opts->{prefix} . _escape_uri $opts, $tag;
533 $title = $tag;
534 }
535 }
536
537 return "<a$class href='$href'>$title</a>$trailing";
452 sub _make_html_link {
453 my ( $tag, $opts, $tags ) = @_;
454
455 my ( $class, $trailing ) = ( '', '' );
456 my ( $href, $title );
457 if ( $tag =~ /^\[\[([^|#]*)(?:(#)([^|]*))?(?:(\|)(.*))?\]\]$/ ) {
458
459 # Wiki link
460 $href = $opts->{prefix} . _escape_uri $opts, $1 if $1;
461 $href .= $2 . _escape_uri $opts, $3 if $2;
462
463 if ($4) {
464
465 # Title specified explicitly.
466 if ( length $5 ) {
467 $title = $5;
468 }
469 else {
470 # An empty title asks Mediawiki to strip any parens off the end
471 # of the node name.
472 $1 =~ /^([^(]*)(?:\s*\()?/;
473 $title = $1;
474 }
475 }
476 else {
477 # Title defaults to the node name.
478 $title = $1;
479 }
480 }
481 elsif ( $tag =~ /^\[(\S*)(?:(\s+)(.*))?\]$/ ) {
482
483 # URI
484 $href = $1;
485 if ($2) {
486 $title = $3;
487 }
488 else {
489 $title = ++$opts->{_uri_refs};
490 }
491 $href =~ s/'/%27/g;
492 }
493 else {
494 # Shouldn't be able to get here without either $opts->{absolute_links}
495 # or $opts->{implicit_links};
496 $tags->{_schema_regex} ||= _make_schema_regex @{ $tags->{schemas} };
497 my $s = $tags->{_schema_regex};
498
499 if ( $tag =~ /^$s:[$uricCheat][$uric]*$/ ) {
500
501 # absolute link
502 $href = $&;
503 $trailing = $& if $href =~ s/[$uriCruft]$//;
504 $title = $href;
505 }
506 else {
507 # StudlyCaps
508 $href = $opts->{prefix} . _escape_uri $opts, $tag;
509 $title = $tag;
510 }
511 }
512
513 return "<a$class href='$href'>$title</a>$trailing";
538514 }
539515
540516 # Store a TOC line for later.
541517 #
542518 # ASSUMPTIONS
543519 # $level >= 1
544 sub _store_toc_line
545 {
546 my ($toc, $level, $title, $name) = @_;
547
548 # TODO: Strip formatting from $title.
549
550 if (@$toc && $level > $toc->[-1]->{level})
551 {
552 # Nest a sublevel.
553 $toc->[-1]->{sublevel} = []
554 unless exists $toc->[-1]->{sublevel};
555 _store_toc_line ($toc->[-1]->{sublevel}, $level, $title, $name);
556 }
557 else
558 {
559 push @$toc, {level => $level, title => $title, name => $name};
560 }
561
562 return $level;
520 sub _store_toc_line {
521 my ( $toc, $level, $title, $name ) = @_;
522
523 # TODO: Strip formatting from $title.
524
525 if ( @$toc && $level > $toc->[-1]->{level} ) {
526
527 # Nest a sublevel.
528 $toc->[-1]->{sublevel} = []
529 unless exists $toc->[-1]->{sublevel};
530 _store_toc_line( $toc->[-1]->{sublevel}, $level, $title, $name );
531 }
532 else {
533 push @$toc, { level => $level, title => $title, name => $name };
534 }
535
536 return $level;
563537 }
564538
565539 # Make header text, storing the line for the TOC.
566540 #
567541 # ASSUMPTIONS
568542 # $tags->{_toc} has been initialized to an array ref.
569 sub _make_header
570 {
571 my $level = length $_[2];
572 my $n = _escape_uri $_[-1], $_[3];
573
574 _store_toc_line ($_[-2]->{_toc}, $level, $_[3], $n);
575
576 return "<a name='$n'></a><h$level>",
577 Text::MediawikiFormat::format_line ($_[3], @_[-2, -1]),
578 "</h$level>\n";
579 }
580
581 sub _format
582 {
583 my ($itags, $iopts, $text, $tags, $opts) = @_;
543 sub _make_header {
544 my $level = length $_[2];
545 my $n = _escape_uri $_[-1], $_[3];
546
547 _store_toc_line( $_[-2]->{_toc}, $level, $_[3], $n );
548
549 return "<a name='$n'></a><h$level>", Text::MediawikiFormat::format_line( $_[3], @_[ -2, -1 ] ), "</h$level>\n";
550 }
551
552 sub _format {
553 my ( $itags, $iopts, $text, $tags, $opts ) = @_;
584554
585555 # Overwriting the caller's hashes locally after merging its contents
586556 # is okay.
587 $tags = _merge_hashes ($tags || {}, $itags);
588 $opts = _merge_hashes ($opts || {}, $iopts);
557 $tags = _merge_hashes( $tags || {}, $itags );
558 $opts = _merge_hashes( $opts || {}, $iopts );
589559
590560 _require_html_packages
591 if $opts->{process_html};
561 if $opts->{process_html};
592562
593563 # Always verify the blocks since the user may have slagged the
594564 # default hash on import.
595 _check_blocks ($tags);
596
597 my @blocks = _find_blocks ($text, $tags, $opts);
598 @blocks = _nest_blocks (\@blocks);
599 return _process_blocks (\@blocks, $tags, $opts);
600 }
601
602 sub _check_blocks
603 {
604 my $tags = shift;
605 my %blocks = %{$tags->{blocks}};
606 delete @blocks{@{$tags->{blockorder}}};
607
608 carp
609 "No order specified for blocks: "
610 . join (', ', keys %blocks)
611 . ".\n"
612 if keys %blocks;
565 _check_blocks($tags);
566
567 my @blocks = _find_blocks( $text, $tags, $opts );
568 @blocks = _nest_blocks( \@blocks );
569 return _process_blocks( \@blocks, $tags, $opts );
570 }
571
572 sub _check_blocks {
573 my $tags = shift;
574 my %blocks = %{ $tags->{blocks} };
575 delete @blocks{ @{ $tags->{blockorder} } };
576
577 carp "No order specified for blocks: " . join( ', ', keys %blocks ) . ".\n"
578 if keys %blocks;
613579 }
614580
615581 # This sub recognizes three states:
626592 #
627593 # Each state may override the lower ones if already set on a given line.
628594 #
629 sub _append_processed_line
630 {
631 my ($parser, $text, $state) = @_;
632 my $lines = $parser->{processed_lines};
633
634 $state ||= '';
635
636 my @newlines = split /(?<=\n)/, $text;
637 if (@$lines && $lines->[-1]->[1] !~ /\n$/
638 && # State not changing from or to 'nowiki'
639 !($state ne $lines->[-1]->[0]
640 && grep /^nowiki$/, $state, $lines->[-1]->[0]))
641 {
642 $lines->[-1]->[1] .= shift @newlines;
643 $lines->[-1]->[0] = $state if $state eq 'html';
644 }
645
646 foreach my $line (@newlines)
647 {
648 $lines->[-1]->[2] = '1' if @$lines;
649 push @$lines, [$state, $line];
650 }
651 $lines->[-1]->[2] = '1'
652 if @$lines && $lines->[-1]->[1] =~ /\n$/;
653 }
654
655 sub _html_tag
656 {
657 my ($parser, $type, $tagname, $orig, $attr) = @_;
658 my $tags = $parser->{tags};
659
660 # $tagname may have been generated by an empty tag. If so, HTML::Parser
661 # will sometimes include the trailing / in the tag name.
662 my $isEmptyTag = $orig =~ m#/>$#;
663 $tagname =~ s#/$## if $isEmptyTag;
664
665 unless (grep /^\Q$tagname\E$/, @{$tags->{allowed_tags}})
666 {
667 _append_processed_line $parser, CGI::escapeHTML $orig;
595 sub _append_processed_line {
596 my ( $parser, $text, $state ) = @_;
597 my $lines = $parser->{processed_lines};
598
599 $state ||= '';
600
601 my @newlines = split /(?<=\n)/, $text;
602 if (
603 @$lines
604 && $lines->[-1]->[1] !~ /\n$/
605 && # State not changing from or to 'nowiki'
606 !( $state ne $lines->[-1]->[0] && grep /^nowiki$/, $state, $lines->[-1]->[0] )
607 )
608 {
609 $lines->[-1]->[1] .= shift @newlines;
610 $lines->[-1]->[0] = $state if $state eq 'html';
611 }
612
613 foreach my $line (@newlines) {
614 $lines->[-1]->[2] = '1' if @$lines;
615 push @$lines, [ $state, $line ];
616 }
617 $lines->[-1]->[2] = '1'
618 if @$lines && $lines->[-1]->[1] =~ /\n$/;
619 }
620
621 sub _html_tag {
622 my ( $parser, $type, $tagname, $orig, $attr ) = @_;
623 my $tags = $parser->{tags};
624
625 # $tagname may have been generated by an empty tag. If so, HTML::Parser
626 # will sometimes include the trailing / in the tag name.
627 my $isEmptyTag = $orig =~ m#/>$#;
628 $tagname =~ s#/$## if $isEmptyTag;
629
630 unless ( grep /^\Q$tagname\E$/, @{ $tags->{allowed_tags} } ) {
631 _append_processed_line $parser, CGI::escapeHTML $orig;
632 return;
633 }
634
635 # Any $tagname must now be in the allowed list, including <nowiki>.
636
637 my $tagstack = $parser->{tag_stack};
638 my $stacktop = @$tagstack ? $tagstack->[-1] : '';
639
640 # First, process end tags, since they can change our state.
641 if ( $type eq 'E' && $stacktop eq $tagname ) {
642
643 # The closing tag is at the top of the stack, like it should be.
644 # Pop it and append the close tag to the output.
645 pop @$tagstack;
646 my $newtag;
647
648 if ( $tagname eq 'nowiki' ) {
649
650 # The browser doesn't need to see the </nowiki> tag.
651 $newtag = '';
652 }
653 else {
654 $newtag = "</$tagname>";
655 }
656
657 # Can't close a state into <pre> or <nowiki>
658 _append_processed_line $parser, $newtag, 'html';
659 return;
660 }
661
662 if ( @$tagstack && grep /^\Q$stacktop\E$/, qw{nowiki pre} ) {
663
664 # Ignore all markup within <pre> or <nowiki> tags.
665 _append_processed_line $parser, CGI::escapeHTML($orig), 'nowiki';
666 return;
667 }
668
669 if ( $type eq 'E' && $HTML::Tagset::isPhraseMarkup{$tagname} )
670
671 # If we ask for artificial end element events for self-closed elements,
672 # then we need to check $HTML::Tagset::emptyElement($tagname) here too.
673 {
674 # We didn't record phrase markup on the stack, so it's okay to just
675 # let it close.
676 _append_processed_line $parser, "</$tagname>";
677 return;
678 }
679
680 if ( $type eq 'E' ) {
681
682 # We got a non-phrase end tag that wasn't on the stack. Escape it.
683 _append_processed_line $parser, CGI::escapeHTML($orig);
684 return;
685 }
686
687 ###
688 ### $type must now eq 'S'.
689 ###
690
691 # The browser doesn't need to see the <nowiki> tag.
692 if ( $tagname eq 'nowiki' ) {
693 push @$tagstack, $tagname
694 unless $isEmptyTag;
695 return;
696 }
697
698 # Strip disallowed attributes.
699 my $newtag = "<$tagname";
700 foreach ( @{ $tags->{allowed_attrs} } ) {
701 if ( defined $attr->{$_} ) {
702 $newtag .= " $_";
703 unless ( $attr->{$_} eq '__TEXT_MEDIAWIKIFORMAT_BOOL__' ) {
704
705 # CGI::escapeHTML escapes single quotes.
706 $attr->{$_} = CGI::escapeHTML $attr->{$_};
707 $newtag .= "='" . $attr->{$_} . "'";
708 }
709 }
710 }
711 $newtag .= " /" if $HTML::Tagset::emptyElement{$tagname} || $isEmptyTag;
712 $newtag .= ">";
713
714 # If this isn't a block level element, there's no need to track nesting.
715 if ( $HTML::Tagset::isPhraseMarkup{$tagname}
716 || $HTML::Tagset::emptyElement{$tagname} )
717 {
718 _append_processed_line $parser, $newtag;
719 return;
720 }
721
722 # Some elements can close implicitly
723 if (@$tagstack) {
724 if ( $tagname eq $stacktop
725 && $HTML::Tagset::optionalEndTag{$tagname} )
726 {
727 pop @$tagstack;
728 }
729 elsif ( !$HTML::Tagset::is_Possible_Strict_P_Content{$tagname} ) {
730
731 # Need to check more than the last item for paragraphs.
732 for ( my $i = $#{$tagstack}; $i >= 0; $i-- ) {
733 my $checking = $tagstack->[$i];
734 last if grep /^\Q$checking\E$/, @HTML::Tagset::p_closure_barriers;
735
736 if ( $checking eq 'p' ) {
737
738 # pop 'em all.
739 splice @$tagstack, $i;
740 last;
741 }
742 }
743 }
744 }
745
746 # Could verify here that <li> and <table> sub-elements only appear where
747 # they belong.
748
749 # Push the new tag onto the stack.
750 push @$tagstack, $tagname
751 unless $isEmptyTag;
752
753 _append_processed_line $parser, $newtag, $tagname eq 'pre' ? 'nowiki' : 'html';
668754 return;
669 }
670 # Any $tagname must now be in the allowed list, including <nowiki>.
671
672 my $tagstack = $parser->{tag_stack};
673 my $stacktop = @$tagstack ? $tagstack->[-1] : '';
674
675 # First, process end tags, since they can change our state.
676 if ($type eq 'E' && $stacktop eq $tagname)
677 {
678 # The closing tag is at the top of the stack, like it should be.
679 # Pop it and append the close tag to the output.
680 pop @$tagstack;
681 my $newtag;
682
683 if ($tagname eq 'nowiki')
755 }
756
757 sub _html_comment {
758 my ( $parser, $text ) = @_;
759
760 _append_processed_line $parser, $text, 'nowiki';
761 }
762
763 sub _html_text {
764 my ( $parser, $dtext, $skipped_text, $is_cdata ) = @_;
765 my $tagstack = $parser->{tag_stack};
766 my ( $newtext, $newstate );
767
768 warnings::warnif("Got skipped_text: `$skipped_text'")
769 if $skipped_text;
770
771 if (@$tagstack) {
772 if ( grep /\Q$tagstack->[-1]\E/, qw{nowiki pre} ) {
773 $newstate = 'nowiki';
774 }
775 elsif ( $is_cdata && $HTML::Tagset::isCDATA_Parent{ $tagstack->[-1] } ) {
776
777 # If the user hadn't specifically allowed a tag which contains
778 # CDATA, then it won't be on the tag stack.
779 $newtext = $dtext;
780 }
781 }
782
783 unless ( defined $newtext ) {
784 $newtext = CGI::escapeHTML $dtext unless defined $newtext;
785
786 # CGI::escapeHTML escapes single quotes so the text may be included
787 # in attribute values, but we know we aren't processing an attribute
788 # value here.
789 $newtext =~ s/&#39;/'/g;
790 }
791
792 _append_processed_line $parser, $newtext, $newstate;
793 }
794
795 sub _find_blocks_in_html {
796 my ( $text, $tags, $opts ) = @_;
797
798 my $parser = HTML::Parser->new(
799 start_h => [ \&_html_tag, 'self, "S", tagname, text, attr' ],
800 end_h => [ \&_html_tag, 'self, "E", tagname, text' ],
801 comment_h => [ \&_html_comment, 'self, text' ],
802 text_h => [ \&_html_text, 'self, dtext, skipped_text, is_cdata' ],
803 marked_sections => 1,
804 boolean_attribute_value => '__TEXT_MEDIAWIKIFORMAT_BOOL__',
805 );
806 $parser->{opts} = $opts;
807 $parser->{tags} = $tags;
808 $parser->{processed_lines} = [];
809 $parser->{tag_stack} = [];
810
811 my @blocks;
812 my @lines = split /\r?\n/, $text;
813 for ( my $i = 0; $i < @lines; $i++ ) {
814 $parser->parse( $lines[$i] );
815 $parser->parse("\n");
816 $parser->eof if $i == $#lines;
817
818 # @{$parser->{processed_lines}} may be empty when tags are
819 # still open.
820 while ( @{ $parser->{processed_lines} }
821 && $parser->{processed_lines}->[0]->[2] )
822 {
823 my ( $type, $dtext )
824 = @{ shift @{ $parser->{processed_lines} } };
825
826 my $block;
827 if ($type) {
828 $block = _start_block( $dtext, $tags, $opts, $type );
829 }
830 else {
831 chomp $dtext;
832 $block = _start_block( $dtext, $tags, $opts );
833 }
834 push @blocks, $block if $block;
835 }
836 }
837
838 return @blocks;
839 }
840
841 sub _find_blocks {
842 my ( $text, $tags, $opts ) = @_;
843 my @blocks;
844
845 if ( $opts->{process_html} ) {
846 @blocks = _find_blocks_in_html $text, $tags, $opts;
847 }
848 else {
849 # The original behavior.
850 for my $line ( split /\r?\n/, $text ) {
851 my $block = _start_block( $line, $tags, $opts );
852 push @blocks, $block if $block;
853 }
854 }
855
856 return @blocks;
857 }
858
859 sub _start_block {
860 my ( $text, $tags, $opts, $type ) = @_;
861
862 return new_block( 'end', level => 0 ) unless $text;
863 return new_block(
864 $type,
865 level => 0,
866 opts => $opts,
867 text => $text,
868 tags => $tags,
869 ) if $type;
870
871 for my $block ( @{ $tags->{blockorder} } ) {
872 my ( $line, $level, $indentation ) = ( $text, 0, '' );
873
874 ( $level, $line, $indentation ) = _get_indentation( $tags, $line )
875 if $tags->{indented}{$block};
876
877 my $marker_removed = length( $line =~ s/$tags->{blocks}{$block}// );
878
879 next unless $marker_removed;
880
881 return new_block(
882 $block,
883 args => [ grep {defined} $1, $2, $3, $4, $5, $6, $7, $8, $9 ],
884 level => $level || 0,
885 opts => $opts,
886 text => $line,
887 tags => $tags,
888 );
889 }
890 }
891
892 sub _nest_blocks {
893 my $blocks = shift;
894 return unless @$blocks;
895
896 my @processed = shift @$blocks;
897
898 for my $block (@$blocks) {
899 push @processed, $processed[-1]->nest($block);
900 }
901
902 return @processed;
903 }
904
905 sub _process_blocks {
906 my ( $blocks, $tags, $opts ) = @_;
907
908 my @open;
909 for my $block (@$blocks) {
910 push @open, _process_block( $block, $tags, $opts )
911 unless $block->type() eq 'end';
912 }
913
914 return join '', @open;
915 }
916
917 sub _process_block {
918 my ( $block, $tags, $opts ) = @_;
919 my $type = $block->type();
920
921 my ( $start, $end, $start_line, $end_line, $between );
922 if ( $tags->{$type} ) {
923 ( $start, $end, $start_line, $end_line, $between ) = @{ $tags->{$type} };
924 }
925 else {
926 ( $start, $end, $start_line, $end_line ) = ( '', '', '', '' );
927 }
928
929 my @text = ();
930 for my $line (
931 grep ( /^\Q$type\E$/, @{ $tags->{unformatted_blocks} } )
932 ? $block->text()
933 : $block->formatted_text()
934 )
684935 {
685 # The browser doesn't need to see the </nowiki> tag.
686 $newtag = '';
687 }
688 else
689 {
690 $newtag = "</$tagname>";
691 }
692
693 # Can't close a state into <pre> or <nowiki>
694 _append_processed_line $parser, $newtag, 'html';
695 return;
696 }
697
698 if (@$tagstack && grep /^\Q$stacktop\E$/, qw{nowiki pre})
699 {
700 # Ignore all markup within <pre> or <nowiki> tags.
701 _append_processed_line $parser, CGI::escapeHTML ($orig), 'nowiki';
702 return;
703 }
704
705 if ($type eq 'E' && $HTML::Tagset::isPhraseMarkup{$tagname})
706 # If we ask for artificial end element events for self-closed elements,
707 # then we need to check $HTML::Tagset::emptyElement($tagname) here too.
708 {
709 # We didn't record phrase markup on the stack, so it's okay to just
710 # let it close.
711 _append_processed_line $parser, "</$tagname>";
712 return;
713 }
714
715 if ($type eq 'E')
716 {
717 # We got a non-phrase end tag that wasn't on the stack. Escape it.
718 _append_processed_line $parser, CGI::escapeHTML ($orig);
719 return;
720 }
721
722
723 ###
724 ### $type must now eq 'S'.
725 ###
726
727 # The browser doesn't need to see the <nowiki> tag.
728 if ($tagname eq 'nowiki')
729 {
730 push @$tagstack, $tagname
731 unless $isEmptyTag;
732 return;
733 }
734
735 # Strip disallowed attributes.
736 my $newtag = "<$tagname";
737 foreach (@{$tags->{allowed_attrs}})
738 {
739 if (defined $attr->{$_})
740 {
741 $newtag .= " $_";
742 unless ($attr->{$_}
743 eq '__TEXT_MEDIAWIKIFORMAT_BOOL__')
744 {
745 # CGI::escapeHTML escapes single quotes.
746 $attr->{$_} = CGI::escapeHTML $attr->{$_};
747 $newtag .= "='" . $attr->{$_} . "'";
748 }
749 }
750 }
751 $newtag .= " /" if $HTML::Tagset::emptyElement{$tagname} || $isEmptyTag;
752 $newtag .= ">";
753
754 # If this isn't a block level element, there's no need to track nesting.
755 if ($HTML::Tagset::isPhraseMarkup{$tagname}
756 || $HTML::Tagset::emptyElement{$tagname})
757 {
758 _append_processed_line $parser, $newtag;
759 return;
760 }
761
762 # Some elements can close implicitly
763 if (@$tagstack)
764 {
765 if ($tagname eq $stacktop
766 && $HTML::Tagset::optionalEndTag{$tagname})
767 {
768 pop @$tagstack;
769 }
770 elsif (!$HTML::Tagset::is_Possible_Strict_P_Content{$tagname})
771 {
772 # Need to check more than the last item for paragraphs.
773 for (my $i = $#{$tagstack}; $i >= 0; $i--)
774 {
775 my $checking = $tagstack->[$i];
776 last if grep /^\Q$checking\E$/,
777 @HTML::Tagset::p_closure_barriers;
778
779 if ($checking eq 'p')
780 {
781 # pop 'em all.
782 splice @$tagstack, $i;
783 last;
784 }
785 }
786 }
787 }
788
789 # Could verify here that <li> and <table> sub-elements only appear where
790 # they belong.
791
792 # Push the new tag onto the stack.
793 push @$tagstack, $tagname
794 unless $isEmptyTag;
795
796 _append_processed_line $parser, $newtag,
797 $tagname eq 'pre' ? 'nowiki' : 'html';
798 return;
799 }
800
801 sub _html_comment
802 {
803 my ($parser, $text) = @_;
804
805 _append_processed_line $parser, $text, 'nowiki';
806 }
807
808 sub _html_text
809 {
810 my ($parser, $dtext, $skipped_text, $is_cdata) = @_;
811 my $tagstack = $parser->{tag_stack};
812 my ($newtext, $newstate);
813
814 warnings::warnif ("Got skipped_text: `$skipped_text'")
815 if $skipped_text;
816
817 if (@$tagstack)
818 {
819 if (grep /\Q$tagstack->[-1]\E/, qw{nowiki pre})
820 {
821 $newstate = 'nowiki'
822 }
823 elsif ($is_cdata && $HTML::Tagset::isCDATA_Parent{$tagstack->[-1]})
824 {
825 # If the user hadn't specifically allowed a tag which contains
826 # CDATA, then it won't be on the tag stack.
827 $newtext = $dtext;
828 }
829 }
830
831 unless (defined $newtext)
832 {
833 $newtext = CGI::escapeHTML $dtext unless defined $newtext;
834 # CGI::escapeHTML escapes single quotes so the text may be included
835 # in attribute values, but we know we aren't processing an attribute
836 # value here.
837 $newtext =~ s/&#39;/'/g;
838 }
839
840 _append_processed_line $parser, $newtext, $newstate;
841 }
842
843 sub _find_blocks_in_html
844 {
845 my ($text, $tags, $opts) = @_;
846
847 my $parser = HTML::Parser->new
848 (start_h => [\&_html_tag, 'self, "S", tagname, text, attr'],
849 end_h => [\&_html_tag, 'self, "E", tagname, text'],
850 comment_h => [\&_html_comment, 'self, text'],
851 text_h => [\&_html_text, 'self, dtext, skipped_text, is_cdata'],
852 marked_sections => 1,
853 boolean_attribute_value => '__TEXT_MEDIAWIKIFORMAT_BOOL__',
854 );
855 $parser->{opts} = $opts;
856 $parser->{tags} = $tags;
857 $parser->{processed_lines} = [];
858 $parser->{tag_stack} = [];
859
860 my @blocks;
861 my @lines = split /\r?\n/, $text;
862 for (my $i = 0; $i < @lines; $i++)
863 {
864 $parser->parse ($lines[$i]);
865 $parser->parse ("\n");
866 $parser->eof if $i == $#lines;
867
868 # @{$parser->{processed_lines}} may be empty when tags are
869 # still open.
870 while (@{$parser->{processed_lines}}
871 && $parser->{processed_lines}->[0]->[2])
872 {
873 my ($type, $dtext)
874 = @{shift @{$parser->{processed_lines}}};
875
876 my $block;
877 if ($type)
878 {
879 $block = _start_block ($dtext, $tags, $opts, $type);
880 }
881 else
882 {
883 chomp $dtext;
884 $block = _start_block ($dtext, $tags, $opts);
885 }
886 push @blocks, $block if $block;
887 }
888 }
889
890 return @blocks;
891 }
892
893 sub _find_blocks
894 {
895 my ($text, $tags, $opts) = @_;
896 my @blocks;
897
898 if ($opts->{process_html})
899 {
900 @blocks = _find_blocks_in_html $text, $tags, $opts;
901 }
902 else
903 {
904 # The original behavior.
905 for my $line (split /\r?\n/, $text)
906 {
907 my $block = _start_block ($line, $tags, $opts);
908 push @blocks, $block if $block;
909 }
910 }
911
912 return @blocks;
913 }
914
915 sub _start_block
916 {
917 my ($text, $tags, $opts, $type) = @_;
918
919 return new_block ('end', level => 0) unless $text;
920 return new_block ($type,
921 level => 0,
922 opts => $opts,
923 text => $text,
924 tags => $tags,)
925 if $type;
926
927 for my $block (@{$tags->{blockorder}})
928 {
929 my ($line, $level, $indentation) = ($text, 0, '');
930
931 ($level, $line, $indentation) = _get_indentation ($tags, $line)
932 if $tags->{indented}{$block};
933
934 my $marker_removed = length ($line =~ s/$tags->{blocks}{$block}//);
935
936 next unless $marker_removed;
937
938 return new_block ($block,
939 args => [grep {defined} $1, $2, $3, $4, $5, $6, $7,
940 $8, $9],
941 level => $level || 0,
942 opts => $opts,
943 text => $line,
944 tags => $tags,
945 );
946 }
947 }
948
949 sub _nest_blocks
950 {
951 my $blocks = shift;
952 return unless @$blocks;
953
954 my @processed = shift @$blocks;
955
956 for my $block (@$blocks)
957 {
958 push @processed, $processed[-1]->nest( $block );
959 }
960
961 return @processed;
962 }
963
964 sub _process_blocks
965 {
966 my ($blocks, $tags, $opts) = @_;
967
968 my @open;
969 for my $block (@$blocks)
970 {
971 push @open, _process_block ($block, $tags, $opts)
972 unless $block->type() eq 'end';
973 }
974
975 return join '', @open ;
976 }
977
978 sub _process_block
979 {
980 my ($block, $tags, $opts) = @_;
981 my $type = $block->type();
982
983 my ($start, $end, $start_line, $end_line, $between);
984 if ($tags->{$type})
985 {
986 ($start, $end, $start_line, $end_line, $between) = @{$tags->{$type}};
987 }
988 else
989 {
990 ($start, $end, $start_line, $end_line) = ('', '', '', '');
991 }
992
993 my @text = ();
994 for my $line (grep (/^\Q$type\E$/, @{$tags->{unformatted_blocks}})
995 ? $block->text()
996 : $block->formatted_text())
997 {
998 if (blessed $line)
999 {
1000 my $prev_end = pop @text || ();
1001 push @text, _process_block ($line, $tags, $opts), $prev_end;
1002 next;
1003 }
1004
1005 my @triplets;
1006 if ((ref ($start_line) || '') eq 'CODE')
1007 {
1008 @triplets = $start_line->($line, $block->level(),
1009 $block->shift_args(), $tags, $opts);
1010 }
1011 else
1012 {
1013 @triplets = ($start_line, $line, $end_line);
1014 }
1015 push @text, @triplets;
1016 }
1017
1018 pop @text if $between;
1019 return join '', $start, @text, $end;
1020 }
1021
1022 sub _get_indentation
1023 {
1024 my ($tags, $text) = @_;
936 if ( blessed $line) {
937 my $prev_end = pop @text || ();
938 push @text, _process_block( $line, $tags, $opts ), $prev_end;
939 next;
940 }
941
942 my @triplets;
943 if ( ( ref($start_line) || '' ) eq 'CODE' ) {
944 @triplets = $start_line->( $line, $block->level(), $block->shift_args(), $tags, $opts );
945 }
946 else {
947 @triplets = ( $start_line, $line, $end_line );
948 }
949 push @text, @triplets;
950 }
951
952 pop @text if $between;
953 return join '', $start, @text, $end;
954 }
955
956 sub _get_indentation {
957 my ( $tags, $text ) = @_;
1025958
1026959 return 1, $text unless $text =~ s/($tags->{indent})//;
1027 return length ($1) + 1, $text, $1;
960 return length($1) + 1, $text, $1;
1028961 }
1029962
1030963 =head2 format_line
1041974
1042975 =cut
1043976
1044 sub format_line
1045 {
1046 my ($text, $tags, $opts) = @_;
977 sub format_line {
978 my ( $text, $tags, $opts ) = @_;
1047979
1048980 $text =~ s!$tags->{strong_tag}!$tags->{strong}->($1, $opts)!eg;
1049981 $text =~ s!$tags->{emphasized_tag}!$tags->{emphasized}->($1, $opts)!eg;
1050982
1051 $text = _find_links ($text, $tags, $opts)
1052 if $opts->{extended}
1053 || $opts->{absolute_links}
1054 || $opts->{implicit_links};
983 $text = _find_links( $text, $tags, $opts )
984 if $opts->{extended}
985 || $opts->{absolute_links}
986 || $opts->{implicit_links};
1055987
1056988 return $text;
1057989 }
1058990
1059 sub _find_innermost_balanced_pair
1060 {
1061 my ($text, $open, $close) = @_;
1062
1063 my $start_pos = rindex $text, $open;
1064 return if $start_pos == -1;
1065
1066 my $end_pos = index $text, $close, $start_pos;
1067 return if $end_pos == -1;
1068
1069 my $open_length = length $open;
1070 my $close_length = length $close;
1071 my $close_pos = $end_pos + $close_length;
1072 my $enclosed_length = $close_pos - $start_pos;
1073
1074 my $enclosed_atom = substr $text, $start_pos, $enclosed_length;
1075 return substr ($enclosed_atom, $open_length, 0 - $close_length),
1076 substr ($text, 0, $start_pos),
1077 substr ($text, $close_pos);
1078 }
1079
1080 sub _find_links
1081 {
1082 my ($text, $tags, $opts) = @_;
1083
1084 # Build Regexp
1085 my @res;
1086
1087 if ($opts->{absolute_links})
1088 {
1089 # URI
1090 my $s;
1091 $tags->{_schema_regex} ||= _make_schema_regex @{$tags->{schemas}};
1092 $s = $tags->{_schema_regex};
1093 push @res, qr/\b$s:[$uricCheat][$uric]*/
1094 }
1095
1096 if ($opts->{implicit_links})
1097 {
1098 # StudlyCaps
1099 if ($tags->{implicit_link_delimiters})
1100 {
1101 push @res, qr/$tags->{implicit_link_delimiters}/;
1102 }
1103 else
1104 {
1105 warnings::warnif ("Ignoring implicit_links option since implicit_link_delimiters is empty");
1106 }
1107 }
1108
1109 if ($opts->{extended})
1110 {
1111 # [[Wiki Page]]
1112 if (!$tags->{extended_link_delimiters})
1113 {
1114 warnings::warnif ("Ignoring extended option since extended_link_delimiters is empty");
1115 }
1116 elsif (ref $tags->{extended_link_delimiters} eq "ARRAY")
1117 {
1118 # Backwards compatibility for extended links.
1119 # Bypasses the regex substitution used by absolute and implicit
1120 # links.
1121 my ($start, $end) = @{$tags->{extended_link_delimiters}};
1122 while (my @pieces = _find_innermost_balanced_pair ($text, $start,
1123 $end))
1124 {
1125 my ($tag, $before, $after) = map { defined $_ ? $_ : '' }
1126 @pieces;
1127 my $extended = $tags->{link}->($tag, $opts, $tags) || '';
1128 $text = $before . $extended . $after;
1129 }
1130 }
1131 else
1132 {
1133 push @res, qr/$tags->{extended_link_delimiters}/;
1134 }
1135 }
1136
1137 if (@res)
1138 {
1139 my $re = join "|", @res;
1140 $text =~ s/$re/$tags->{link}->($&, $opts, $tags)/ge;
1141 }
1142
1143 return $text;
991 sub _find_innermost_balanced_pair {
992 my ( $text, $open, $close ) = @_;
993
994 my $start_pos = rindex $text, $open;
995 return if $start_pos == -1;
996
997 my $end_pos = index $text, $close, $start_pos;
998 return if $end_pos == -1;
999
1000 my $open_length = length $open;
1001 my $close_length = length $close;
1002 my $close_pos = $end_pos + $close_length;
1003 my $enclosed_length = $close_pos - $start_pos;
1004
1005 my $enclosed_atom = substr $text, $start_pos, $enclosed_length;
1006 return substr( $enclosed_atom, $open_length, 0 - $close_length ),
1007 substr( $text, 0, $start_pos ),
1008 substr( $text, $close_pos );
1009 }
1010
1011 sub _find_links {
1012 my ( $text, $tags, $opts ) = @_;
1013
1014 # Build Regexp
1015 my @res;
1016
1017 if ( $opts->{absolute_links} ) {
1018
1019 # URI
1020 my $s;
1021 $tags->{_schema_regex} ||= _make_schema_regex @{ $tags->{schemas} };
1022 $s = $tags->{_schema_regex};
1023 push @res, qr/\b$s:[$uricCheat][$uric]*/;
1024 }
1025
1026 if ( $opts->{implicit_links} ) {
1027
1028 # StudlyCaps
1029 if ( $tags->{implicit_link_delimiters} ) {
1030 push @res, qr/$tags->{implicit_link_delimiters}/;
1031 }
1032 else {
1033 warnings::warnif("Ignoring implicit_links option since implicit_link_delimiters is empty");
1034 }
1035 }
1036
1037 if ( $opts->{extended} ) {
1038
1039 # [[Wiki Page]]
1040 if ( !$tags->{extended_link_delimiters} ) {
1041 warnings::warnif("Ignoring extended option since extended_link_delimiters is empty");
1042 }
1043 elsif ( ref $tags->{extended_link_delimiters} eq "ARRAY" ) {
1044
1045 # Backwards compatibility for extended links.
1046 # Bypasses the regex substitution used by absolute and implicit
1047 # links.
1048 my ( $start, $end ) = @{ $tags->{extended_link_delimiters} };
1049 while ( my @pieces = _find_innermost_balanced_pair( $text, $start, $end ) ) {
1050 my ( $tag, $before, $after ) = map { defined $_ ? $_ : '' } @pieces;
1051 my $extended = $tags->{link}->( $tag, $opts, $tags ) || '';
1052 $text = $before . $extended . $after;
1053 }
1054 }
1055 else {
1056 push @res, qr/$tags->{extended_link_delimiters}/;
1057 }
1058 }
1059
1060 if (@res) {
1061 my $re = join "|", @res;
1062 $text =~ s/$re/$tags->{link}->($&, $opts, $tags)/ge;
1063 }
1064
1065 return $text;
11441066 }
11451067
11461068 =head1 Wiki Format
11741096 subroutine that already has default tags and options set up. This is
11751097 especially handy if you use a prefix:
11761098
1177 use Text::MediawikiFormat prefix => 'http://www.example.com/';
1178 wikiformat ('some text');
1099 use Text::MediawikiFormat prefix => 'http://www.example.com/';
1100 wikiformat ('some text');
11791101
11801102 Tags are interpreted as default members of the $tags hash normally passed to
11811103 C<format>, except for the five options (see above) and the C<as> key, who's
11841106 To use the C<as> flag to control the name by which your code calls the imported
11851107 function, for example,
11861108
1187 use Text::MediawikiFormat as => 'formatTextWithWikiStyle';
1188 formatTextWithWikiStyle ('some text');
1109 use Text::MediawikiFormat as => 'formatTextWithWikiStyle';
1110 formatTextWithWikiStyle ('some text');
11891111
11901112 You might choose a better name, though.
11911113
11931115 function. Any additional tags or options to the imported function will
11941116 override the defaults. This code:
11951117
1196 use Text::MediawikiFormat as => 'wf', extended => 0;
1197 wf ('some text', {}, {extended => 1});
1118 use Text::MediawikiFormat as => 'wf', extended => 0;
1119 wf ('some text', {}, {extended => 1});
11981120
11991121 enables extended links, after specifying that the default behavior should be
12001122 to disable them.
12141136
12151137 You can change the regular expressions used to find strong and emphasized tags:
12161138
1217 %tags = (
1218 strong_tag => qr/\*([^*]+?)\*/,
1219 emphasized_tag => qr|/([^/]+?)/|,
1220 );
1221
1222 $wikitext = 'this is *strong*, /emphasized/, and */em+strong/*';
1223 $htmltext = wikiformat ($wikitext, \%tags, {});
1139 %tags = (
1140 strong_tag => qr/\*([^*]+?)\*/,
1141 emphasized_tag => qr|/([^/]+?)/|,
1142 );
1143
1144 $wikitext = 'this is *strong*, /emphasized/, and */em+strong/*';
1145 $htmltext = wikiformat ($wikitext, \%tags, {});
12241146
12251147 You can also change the regular expressions used to find links. The following
12261148 just sets them to their default states (but enables parsing of implicit links,
12271149 which is I<not> the default):
12281150
1229 my $html = wikiformat
1230 (
1231 $raw,
1232 {implicit_link_delimiters => qr!\b(?:[A-Z][a-z0-9]\w*){2,}!,
1233 extended_link_delimiters => qr!\[(?:\[[^][]*\]|[^][]*)\]!,
1234 },
1235 {implicit_links => 1}
1236 );
1151 my $html = wikiformat
1152 (
1153 $raw,
1154 {implicit_link_delimiters => qr!\b(?:[A-Z][a-z0-9]\w*){2,}!,
1155 extended_link_delimiters => qr!\[(?:\[[^][]*\]|[^][]*)\]!,
1156 },
1157 {implicit_links => 1}
1158 );
12371159
12381160 In addition, you may set the function references that format strong and
12391161 emphasized text and links. The strong and emphasized functions receive only
12431165 emphasized formatters to their default state while replacing the link formatter
12441166 with one which strips href information and returns only the title text:
12451167
1246 my $html = wikiformat
1247 (
1248 $raw,
1249 {strong => sub {"<strong>$_[0]</strong>"},
1250 emphasized => sub {"<em>$_[0]</em>"},
1251 link => sub
1252 {
1253 my ($tag, $opts, $tags) = @_;
1254 if ($tag =~ s/^\[\[([^][]+)\]\]$/$1/)
1255 {
1256 my ($page, $title) = split qr/\|/, $tag, 2;
1257 return $title if $title;
1258 return $page;
1259 }
1260 elsif ($tag =~ s/^\[([^][]+)\]$/$1/)
1261 {
1262 my ($href, $title) = split qr/ /, $tag, 2;
1263 return $title if $title;
1264 return $href;
1265 }
1266 else
1267 {
1268 return $tag;
1269 }
1270 },
1271 },
1272 );
1168 my $html = wikiformat
1169 (
1170 $raw,
1171 {strong => sub {"<strong>$_[0]</strong>"},
1172 emphasized => sub {"<em>$_[0]</em>"},
1173 link => sub
1174 {
1175 my ($tag, $opts, $tags) = @_;
1176 if ($tag =~ s/^\[\[([^][]+)\]\]$/$1/)
1177 {
1178 my ($page, $title) = split qr/\|/, $tag, 2;
1179 return $title if $title;
1180 return $page;
1181 }
1182 elsif ($tag =~ s/^\[([^][]+)\]$/$1/)
1183 {
1184 my ($href, $title) = split qr/ /, $tag, 2;
1185 return $title if $title;
1186 return $href;
1187 }
1188 else
1189 {
1190 return $tag;
1191 }
1192 },
1193 },
1194 );
12731195
12741196 =head3 Blocks
12751197
12831205 item. This is how the module processes ordered lines in HTML lists and
12841206 headers:
12851207
1286 my $html = wikiformat
1287 (
1288 $raw,
1289 {ordered => ['<ol>', "</ol>\n", '<li>', "<li>\n"],
1290 header => ['', "\n", \&_make_header],
1291 },
1292 );
1208 my $html = wikiformat
1209 (
1210 $raw,
1211 {ordered => ['<ol>', "</ol>\n", '<li>', "<li>\n"],
1212 header => ['', "\n", \&_make_header],
1213 },
1214 );
12931215
12941216 The first argument to these subrefs is the post-processed text of the line
12951217 itself. (Processing removes the indentation and tokens used to mark this as a
12981220 captured variables in the regular expression used to find this list type. The
12991221 regexp for headers is:
13001222
1301 $html = wikiformat
1302 (
1303 $raw,
1304 {blocks => {header => qr/^(=+)\s*(.+?)\s*\1$/}}
1305 );
1223 $html = wikiformat
1224 (
1225 $raw,
1226 {blocks => {header => qr/^(=+)\s*(.+?)\s*\1$/}}
1227 );
13061228
13071229 The module processes indentation first, if applicable, and stores the
13081230 indentation level (the length of the indentation removed).
13151237 appropriate blocks to process. If you add a block type, be sure to add an
13161238 entry for it in C<blockorder>:
13171239
1318 my $html = wikiformat
1319 (
1320 $raw,
1321 {invisible => ['', '', '', ''],
1322 blocks => {invisible => qr!^--(.*?)--$!},
1323 blockorder => [qw(code header line ordered
1324 unordered definition invisible
1325 paragraph_break paragraph)]
1326 },
1327 },
1328 );
1240 my $html = wikiformat
1241 (
1242 $raw,
1243 {invisible => ['', '', '', ''],
1244 blocks => {invisible => qr!^--(.*?)--$!},
1245 blockorder => [qw(code header line ordered
1246 unordered definition invisible
1247 paragraph_break paragraph)]
1248 },
1249 },
1250 );
13291251
13301252 =head3 Finding blocks
13311253
13341256 key. For example, to change the regular expression to find code block items,
13351257 use:
13361258
1337 my $html = wikiformat ($raw, {blocks => {code => qr/^:\s+/}});
1259 my $html = wikiformat ($raw, {blocks => {code => qr/^:\s+/}});
13381260
13391261 This will require a leading colon to mark code lines (note that as writted
13401262 here, this would interfere with the default processing of definition lists).
14341356
14351357 =cut
14361358
1437 1; # End of Text::MediaiwkiFormat
1359 1; # End of Text::MediaiwkiFormat
+68
-71
t/Wiki.t less more
55 use warnings;
66
77 # for testing 'rootdir' in links
8 my %constants = (
9 rootdir => 'rootdir',
10 );
8 my %constants = ( rootdir => 'rootdir', );
119
1210 local *Text::MediawikiFormat::getCurrentStatic;
1311 *Text::MediawikiFormat::getCurrentStatic = sub {
1917
2018 use_ok 'Text::MediawikiFormat';
2119
22 my $wikitext =<<WIKI;
20 my $wikitext = <<WIKI;
2321 '''hello'''
2422 ''hi''
2523 -----
3937
4038 WIKI
4139
42 ok %Text::MediawikiFormat::tags,
43 '%tags should be available from Text::MediawikiFormat';
40 ok %Text::MediawikiFormat::tags, '%tags should be available from Text::MediawikiFormat';
4441 my %tags = %Text::MediawikiFormat::tags;
4542
46 ok %Text::MediawikiFormat::opts,
47 '%opts should be available from Text::MediawikiFormat';
43 ok %Text::MediawikiFormat::opts, '%opts should be available from Text::MediawikiFormat';
4844 my %opts = (
4945 %Text::MediawikiFormat::opts,
50 prefix => 'rootdir/wiki.pl?page=',
46 prefix => 'rootdir/wiki.pl?page=',
5147 implicit_links => 1,
52 extended => 0,
53 process_html => 0,
48 extended => 0,
49 process_html => 0,
5450 );
5551
56 my $htmltext = Text::MediawikiFormat::format_line ($wikitext, \%tags, \%opts);
52 my $htmltext = Text::MediawikiFormat::format_line( $wikitext, \%tags, \%opts );
5753
58 like $htmltext, qr!\[<a href='rootdir/wiki\.pl\?page=LinkMeElsewhere'>!,
59 'format_line () should link StudlyCaps where found)';
54 like $htmltext, qr!\[<a href='rootdir/wiki\.pl\?page=LinkMeElsewhere'>!,
55 'format_line () should link StudlyCaps where found)';
6056 like $htmltext, qr!<strong>hello</strong>!, 'three ticks should mark strong';
61 like $htmltext, qr!<em>hi</em>!, 'two ticks should mark emphasized';
57 like $htmltext, qr!<em>hi</em>!, 'two ticks should mark emphasized';
6258 like $htmltext, qr!LinkMeSomewhere</a>\n!m, 'should catch StudlyCaps';
63 like $htmltext, qr!\[\[!, 'should not handle extended links without flag';
59 like $htmltext, qr!\[\[!, 'should not handle extended links without flag';
6460
6561 $opts{extended} = 1;
66 $htmltext = Text::MediawikiFormat::format_line ($wikitext, \%tags, \%opts);
67 like $htmltext, qr!^<a href='rootdir/wiki\.pl\?page=LinkMeElsewhere'>BYE!m,
68 'should handle extended links with flag';
62 $htmltext = Text::MediawikiFormat::format_line( $wikitext, \%tags, \%opts );
63 like $htmltext, qr!^<a href='rootdir/wiki\.pl\?page=LinkMeElsewhere'>BYE!m, 'should handle extended links with flag';
6964
70 $htmltext = Text::MediawikiFormat::format ($wikitext, {}, {process_html => 0});
65 $htmltext = Text::MediawikiFormat::format( $wikitext, {}, { process_html => 0 } );
7166 like $htmltext, qr!<strong>hello</strong>!, 'three ticks should mark strong';
72 like $htmltext, qr!<em>hi</em>!, 'two ticks should mark emphasized';
67 like $htmltext, qr!<em>hi</em>!, 'two ticks should mark emphasized';
7368
74 is scalar @{$tags{ordered}}, 4,
75 '...default ordered entry should have four items';
76 is join ('', map {ref $_} @{$tags{ordered}}), '',
77 '...and should have no subrefs';
69 is scalar @{ $tags{ordered} }, 4, '...default ordered entry should have four items';
70 is join( '', map { ref $_ } @{ $tags{ordered} } ), '', '...and should have no subrefs';
7871
7972 # make sure this starts a paragraph (buglet)
80 $htmltext = Text::MediawikiFormat::format ("nothing to see here\nmoveAlong\n",
81 {},
82 {prefix => 'foo=',
83 process_html => 0});
73 $htmltext = Text::MediawikiFormat::format(
74 "nothing to see here\nmoveAlong\n",
75 {},
76 {
77 prefix => 'foo=',
78 process_html => 0
79 }
80 );
8481 like $htmltext, qr!^<p>nothing!, '...should start new text with paragraph';
8582
8683 # another buglet had the wrong tag pairs when ending a list
87 my $wikiexample =<<WIKIEXAMPLE;
84 my $wikiexample = <<WIKIEXAMPLE;
8885 I am modifying this because ItIsFun. There is:
8986 # MuchJoy
9087 # MuchFun
10097
10198 WIKIEXAMPLE
10299
103 $htmltext = Text::MediawikiFormat::format ($wikiexample, {},
104 {prefix => 'foo=',
105 process_html => 0});
100 $htmltext = Text::MediawikiFormat::format(
101 $wikiexample,
102 {},
103 {
104 prefix => 'foo=',
105 process_html => 0
106 }
107 );
106108
107 like $htmltext, qr!^<p>I am modifying this!,
108 '... should use correct tags when ending lists';
109 like $htmltext, qr!<p>Here is a paragraph.\n!,
110 '...should add no newline before paragraph, but at newline in paragraph';
111 like $htmltext, qr!<p>Here is another paragraph.</p>!,
112 '... should add no newline at end of paragraph';
113 like $htmltext, qr|<em>emphatic text</em>|,
114 '...should sub markup in code sections';
115 unlike $htmltext, qr!<(\w+)></\1>!, '...but should not create empty lists';
109 like $htmltext, qr!^<p>I am modifying this!, '... should use correct tags when ending lists';
110 like $htmltext, qr!<p>Here is a paragraph.\n!, '...should add no newline before paragraph, but at newline in paragraph';
111 like $htmltext, qr!<p>Here is another paragraph.</p>!, '... should add no newline at end of paragraph';
112 like $htmltext, qr|<em>emphatic text</em>|, '...should sub markup in code sections';
113 unlike $htmltext, qr!<(\w+)></\1>!, '...but should not create empty lists';
116114
117 $wikitext =<<WIKI;
115 $wikitext = <<WIKI;
118116 [escape spaces in links]
119117
120118 WIKI
121119
122120 %opts = (
123 prefix => 'rootdir/wiki.pl?page=',
121 prefix => 'rootdir/wiki.pl?page=',
124122 process_html => 0,
125123 );
126124
127 $htmltext = Text::MediawikiFormat::format ($wikitext, {}, \%opts);
128 like $htmltext, qr!<a href='escape'!m,
129 '...should extended absolute links on spaces';
130 like $htmltext, qr!spaces in links</a>!m,
131 '...should leave spaces alone in titles of extended links';
125 $htmltext = Text::MediawikiFormat::format( $wikitext, {}, \%opts );
126 like $htmltext, qr!<a href='escape'!m, '...should extended absolute links on spaces';
127 like $htmltext, qr!spaces in links</a>!m, '...should leave spaces alone in titles of extended links';
132128
133 $wikitext =<<'WIKI';
129 $wikitext = <<'WIKI';
134130 = heading =
135131 == sub heading ==
136132
142138
143139 WIKI
144140
145 $htmltext = Text::MediawikiFormat::format($wikitext, \%tags, \%opts);
146 like $htmltext, qr!<h1>heading</h1>!, 'headings should be marked';
141 $htmltext = Text::MediawikiFormat::format( $wikitext, \%tags, \%opts );
142 like $htmltext, qr!<h1>heading</h1>!, 'headings should be marked';
147143 like $htmltext, qr!<h2>sub heading</h2>!, '... and numbered appropriately';
148144
149145 # test overridable tags
150146
151 ok !UNIVERSAL::can ('main', 'wikiformat'),
152 'Module should import nothing by default';
147 ok !UNIVERSAL::can( 'main', 'wikiformat' ), 'Module should import nothing by default';
153148
154149 can_ok 'Text::MediawikiFormat', 'import';
155150
156151 SKIP: {
157 # process_html defaults to 1, so we can't test the single-argument version
158 # of the importer without the HTML modules.
159 eval { require HTML::Parser; require HTML::Tagset; };
160 skip "HTML::Parser or HTML::Tagset not installed", 1 if $@;
152 # process_html defaults to 1, so we can't test the single-argument version
153 # of the importer without the HTML modules.
154 eval { require HTML::Parser; require HTML::Tagset; };
155 skip "HTML::Parser or HTML::Tagset not installed", 1 if $@;
161156
162 # given an argument, export wikiformat() somehow
163 package Foo;
157 # given an argument, export wikiformat() somehow
158 package Foo;
164159
165 Text::MediawikiFormat->import('wikiformat');
166 ::can_ok 'Foo', 'wikiformat';
160 Text::MediawikiFormat->import('wikiformat');
161 ::can_ok 'Foo', 'wikiformat';
167162 }
168163
169164 package Bar;
170 Text::MediawikiFormat->import(as => 'wf', prefix => 'foo', tag => 'bar',
171 process_html => 0);
165 Text::MediawikiFormat->import(
166 as => 'wf',
167 prefix => 'foo',
168 tag => 'bar',
169 process_html => 0
170 );
172171 ::can_ok 'Bar', 'wf';
173 ::isnt \&wf, \&Text::MediawikiFormat::format,
174 '...and should be a wrapper around format()';
172 ::isnt \&wf, \&Text::MediawikiFormat::format, '...and should be a wrapper around format()';
175173
176174 my @args;
177175 local *Text::MediawikiFormat::_format;
180178 };
181179
182180 wf();
183 ::is $args[1]{prefix}, 'foo',
184 'imported sub should pass through default option';
185 ::is $args[0]{tag}, 'bar', '... and default tag';
181 ::is $args[1]{prefix}, 'foo', 'imported sub should pass through default option';
182 ::is $args[0]{tag}, 'bar', '... and default tag';
186183
187 wf ('text', {tag2 => 1}, {prefix => 'baz'});
184 wf( 'text', { tag2 => 1 }, { prefix => 'baz' } );
188185 ::is $args[2], 'text', '...passing through text unharmed';
189 ::is $args[3]{tag2}, 1, '...along with new tags';
186 ::is $args[3]{tag2}, 1, '...along with new tags';
190187 ::is $args[4]{prefix}, 'baz', '...overriding default args as needed';
191188
192189 1;
+29
-31
t/absolute_links.t less more
66
77 use Test::More tests => 8;
88 use Test::NoWarnings;
9 use Text::MediawikiFormat as => 'wf', implicit_links => 0, absolute_links => 0,
10 process_html => 0;
9 use Text::MediawikiFormat
10 as => 'wf',
11 implicit_links => 0,
12 absolute_links => 0,
13 process_html => 0;
1114
1215 my $wikitext = <<'WIKI';
1316
1619
1720 WIKI
1821
19 my $htmltext = wf ($wikitext, {}, {absolute_links => 1});
22 my $htmltext = wf( $wikitext, {}, { absolute_links => 1 } );
2023
2124 is $htmltext,
22 qq{<p>I download code from <a href='http://www.cpan.org/'>}
23 . qq{http://www.cpan.org/</a> }
24 . qq{or <a href='ftp://ftp.cpan.org/'>ftp://ftp.cpan.org/</a> and\n}
25 . q{email <a href='mailto:chromatic@example.com'>}
26 . q{mailto:chromatic@example.com</a>}
27 . qq{</p>\n},
28 'Picking up absolute links';
25 qq{<p>I download code from <a href='http://www.cpan.org/'>}
26 . qq{http://www.cpan.org/</a> }
27 . qq{or <a href='ftp://ftp.cpan.org/'>ftp://ftp.cpan.org/</a> and\n}
28 . q{email <a href='mailto:chromatic@example.com'>}
29 . q{mailto:chromatic@example.com</a>}
30 . qq{</p>\n},
31 'Picking up absolute links';
2932
30 $htmltext = wf ($wikitext, {}, {absolute_links => 0});
33 $htmltext = wf( $wikitext, {}, { absolute_links => 0 } );
3134 is $htmltext,
32 qq{<p>I download code from http://www.cpan.org/ or ftp://ftp.cpan.org/ }
33 . qq{and\n}
34 . q{email mailto:chromatic@example.com}
35 . qq{</p>\n},
36 q{Doesn't pick up links when absolute_links is off};
35 qq{<p>I download code from http://www.cpan.org/ or ftp://ftp.cpan.org/ }
36 . qq{and\n}
37 . q{email mailto:chromatic@example.com}
38 . qq{</p>\n},
39 q{Doesn't pick up links when absolute_links is off};
3740
3841 $wikitext = "this is a moose:notalink";
3942
40 $htmltext = wf ($wikitext, {}, {absolute_links => 1});
43 $htmltext = wf( $wikitext, {}, { absolute_links => 1 } );
44 is $htmltext, qq{<p>this is a moose:notalink</p>\n}, q{Doesn't pick up things that might look like links};
45
46 $htmltext = wf( $wikitext, { schemas => ['moose'] }, { absolute_links => 1 } );
4147 is $htmltext,
42 qq{<p>this is a moose:notalink</p>\n},
43 q{Doesn't pick up things that might look like links};
44
45 $htmltext = wf ($wikitext, {schemas => ['moose']}, {absolute_links => 1});
46 is $htmltext,
47 qq{<p>this is a <a href='moose:notalink'>moose:notalink</a></p>\n},
48 q{Schema tag allows specifying what is a link};
48 qq{<p>this is a <a href='moose:notalink'>moose:notalink</a></p>\n},
49 q{Schema tag allows specifying what is a link};
4950
5051 $wikitext = <<'WIKI';
5152
5455 A link in angle brackets: <http://link.org>.
5556 WIKI
5657
57 $htmltext = wf ($wikitext, {}, {absolute_links => 1});
58 like $htmltext, qr{href='http://www.cpan.org/'>},
59 'Links work at beginning of line and lose cruft';
60 like $htmltext, qr{org/</a>\.},
61 'Cruft restored after link';
62 like $htmltext, qr{>http://link\.org</a>>\.},
63 'Angle brackets around links are left alone';
58 $htmltext = wf( $wikitext, {}, { absolute_links => 1 } );
59 like $htmltext, qr{href='http://www.cpan.org/'>}, 'Links work at beginning of line and lose cruft';
60 like $htmltext, qr{org/</a>\.}, 'Cruft restored after link';
61 like $htmltext, qr{>http://link\.org</a>>\.}, 'Angle brackets around links are left alone';
+103
-80
t/base.t less more
1010 use_ok $module or exit;
1111
1212 can_ok $module, '_start_block';
13 my $text =<<END_WIKI;
13 my $text = <<END_WIKI;
1414 = heading =
1515
1616 * unordered item
2222
2323 END_WIKI
2424
25 sub fetchsub
26 {
25 sub fetchsub {
2726 return $module->can( $_[0] );
2827 }
2928
3332 local *Text::MediawikiFormat::opts = $opts;
3433
3534 my $sb = fetchsub '_start_block';
36 my ($result) = $sb->('= heading =', $tags);
37
38 ok $result->isa ('Text::MediawikiFormat::Block::header'),
39 '_start_block() should find headings' or diag "... it's a $result";
40
35 my ($result) = $sb->( '= heading =', $tags );
36
37 ok $result->isa('Text::MediawikiFormat::Block::header'), '_start_block() should find headings'
38 or diag "... it's a $result";
39
4140 is $result->level(), 0, '... at the correct level';
4241
43 ($result) = $sb->('** unordered item', $tags);
44
45 ok $result->isa ('Text::MediawikiFormat::Block::unordered'),
46 '_start_block() should find unordered lists' or diag "... it's a $result";
42 ($result) = $sb->( '** unordered item', $tags );
43
44 ok $result->isa('Text::MediawikiFormat::Block::unordered'), '_start_block() should find unordered lists'
45 or diag "... it's a $result";
4746 is $result->level(), 2, '... at the correct level';
48 is join ('', $result->text()), 'unordered item', '... with the correct text';
49
50 ($result) = $sb->('## ordered item', $tags);
51
52 ok $result->isa ('Text::MediawikiFormat::Block::ordered'),
53 '_start_block() should find ordered lists' or diag "... it's a $result";
47 is join( '', $result->text() ), 'unordered item', '... with the correct text';
48
49 ($result) = $sb->( '## ordered item', $tags );
50
51 ok $result->isa('Text::MediawikiFormat::Block::ordered'), '_start_block() should find ordered lists'
52 or diag "... it's a $result";
5453 is $result->level(), 2, '... at the correct level';
55 is join ('', $result->text()), 'ordered item', '... with the correct text';
56
57 ($result) = $sb->(' some code', $tags);
58
59 ok $result->isa ('Text::MediawikiFormat::Block::code'),
60 '_start_block() should find code' or diag "... it's a $result";
54 is join( '', $result->text() ), 'ordered item', '... with the correct text';
55
56 ($result) = $sb->( ' some code', $tags );
57
58 ok $result->isa('Text::MediawikiFormat::Block::code'), '_start_block() should find code' or diag "... it's a $result";
6159 is $result->level(), 0, '... at the correct level';
62 is join ('', $result->text()), "some code", '... with the correct text';
63
64 ($result) = $sb->('paragraph', $tags);
65
66 ok $result->isa ('Text::MediawikiFormat::Block::paragraph'),
67 '_start_block() should find paragraph' or diag "... it's a $result";
60 is join( '', $result->text() ), "some code", '... with the correct text';
61
62 ($result) = $sb->( 'paragraph', $tags );
63
64 ok $result->isa('Text::MediawikiFormat::Block::paragraph'), '_start_block() should find paragraph'
65 or diag "... it's a $result";
6866 is $result->level(), 0, '... at the correct level';
69 is join ('', $result->text()), 'paragraph', '...with the correct text';
67 is join( '', $result->text() ), 'paragraph', '...with the correct text';
7068
7169 can_ok $module, '_nest_blocks';
72 my $nb = fetchsub '_nest_blocks';
73 my @result = $nb->([
74 map {Text::MediawikiFormat::new_block (@$_)}
75 ['code', text => 'a', level => 1],
76 ['code', text => 'b', level => 1],
77 ]);
70 my $nb = fetchsub '_nest_blocks';
71 my @result = $nb->(
72 [
73 map { Text::MediawikiFormat::new_block(@$_) }[ 'code', text => 'a', level => 1 ],
74 [ 'code', text => 'b', level => 1 ],
75 ]
76 );
7877 is @result, 1, '_nest_blocks() should merge identical blocks together';
7978 is_deeply $result[0]{text}, [qw(a b)], '...merging their text';
8079
81 @result = $nb->([
82 map {Text::MediawikiFormat::new_block (@$_)}
83 ['unordered', text => 'foo', level => 1],
84 ['unordered', text => 'bar', level => 1],
85 ], $tags);
80 @result = $nb->(
81 [
82 map { Text::MediawikiFormat::new_block(@$_) }[ 'unordered', text => 'foo', level => 1 ],
83 [ 'unordered', text => 'bar', level => 1 ],
84 ],
85 $tags
86 );
8687 is @result, 1, '... merging unordered blocks';
8788 is_deeply $result[0]{text}, [qw(foo bar)], '...and their text';
8889
89 @result = $nb->([
90 map {Text::MediawikiFormat::new_block (@$_)}
91 ['ordered', text => 'foo', level => 2],
92 ['ordered', text => 'bar', level => 3],
93 ], $tags);
90 @result = $nb->(
91 [
92 map { Text::MediawikiFormat::new_block(@$_) }[ 'ordered', text => 'foo', level => 2 ],
93 [ 'ordered', text => 'bar', level => 3 ],
94 ],
95 $tags
96 );
9497 is @result, 2, '... not merging blocks at different levels';
9598
9699 can_ok $module, '_process_blocks';
97100 my $pb = fetchsub '_process_blocks';
98 my @opts = (tags => $tags, opts => $opts);
99 my @blocks = map {Text::MediawikiFormat::new_block (@$_, @opts)}
100 ['header', text => [''], level => 0,
101 args => ['==', 'my header']], ['end', text => [ '' ],
102 level => 0, @opts],
103 ['paragraph', text => [qw(my lines of text)], args => [],
104 level => 0],
105 ['end', text => [ '' ], level => 0, @opts ],
106 ['ordered', text => [qw(my ordered lines),
107 Text::MediawikiFormat::new_block
108 ('unordered',
109 text => [qw(my unordered lines)],
110 level => 3, args => [], @opts),],
111 level => 2, args => []];
101 my @opts = ( tags => $tags, opts => $opts );
102 my @blocks = map { Text::MediawikiFormat::new_block( @$_, @opts ) }[
103 'header',
104 text => [''],
105 level => 0,
106 args => [ '==', 'my header' ]
107 ],
108 [
109 'end',
110 text => [''],
111 level => 0,
112 @opts
113 ],
114 [
115 'paragraph',
116 text => [qw(my lines of text)],
117 args => [],
118 level => 0
119 ],
120 [ 'end', text => [''], level => 0, @opts ],
121 [
122 'ordered',
123 text => [
124 qw(my ordered lines),
125 Text::MediawikiFormat::new_block(
126 'unordered',
127 text => [qw(my unordered lines)],
128 level => 3,
129 args => [],
130 @opts
131 ),
132 ],
133 level => 2,
134 args => []
135 ];
112136
113137 # it's hard to fake these up; this may be a bad test
114 $blocks[2]{args} = [[], [], [] ];
115 $blocks[4]{args} = [[2], [3], [5]];
116 $blocks[4]{text}[3]{args} = [[], [], []];
117
118 @result = $pb->(\@blocks, $tags, $opts);
138 $blocks[2]{args} = [ [], [], [] ];
139 $blocks[4]{args} = [ [2], [3], [5] ];
140 $blocks[4]{text}[3]{args} = [ [], [], [] ];
141
142 @result = $pb->( \@blocks, $tags, $opts );
119143
120144 is @result, 1, '_process_blocks() should return processed text';
121145 $result = $result[0];
122 like $result, qr!<h2>my header</h2>!, '...marking header';
123 like $result, qr!<p>my[^<]+text</p>\n!s, '...paragraph';
146 like $result, qr!<h2>my header</h2>!, '...marking header';
147 like $result, qr!<p>my[^<]+text</p>\n!s, '...paragraph';
124148 like $result, qr!<ol>\n<li>my</li>.+<li>lines!s, '...ordered list';
125 like $result, qr!<ul>\n<li>my</li>!m, '...and unordered list';
126 like $result, qr!</li>\n</ul>\n</li>\n</ol>!, '...nesting properly';
127
128 my $f = fetchsub( 'format' );
129 my $fullresult = $f->(<<END_WIKI, $tags, {process_html => 0});
149 like $result, qr!<ul>\n<li>my</li>!m, '...and unordered list';
150 like $result, qr!</li>\n</ul>\n</li>\n</ol>!, '...nesting properly';
151
152 my $f = fetchsub('format');
153 my $fullresult = $f->( <<END_WIKI, $tags, { process_html => 0 } );
130154 == my header ==
131155
132156 my
144168
145169 is $fullresult, $result, 'format() should give same results';
146170
147 $fullresult = $f->(<<END_WIKI, $tags, {process_html => 0});
171 $fullresult = $f->( <<END_WIKI, $tags, { process_html => 0 } );
148172 = heading =
149173
150174 * aliases can expire
161185
162186 END_WIKI
163187
164 like $fullresult, qr!expire<ul>!, 'nested list should start immediately';
188 like $fullresult, qr!expire<ul>!, 'nested list should start immediately';
165189 like $fullresult, qr!date</li>\n</ul>!, '... ending after last nested item';
166190
167191 can_ok $module, '_check_blocks';
171195 push @warnings, shift;
172196 };
173197
174 my $cb = \&Text::MediawikiFormat::_check_blocks;
198 my $cb = \&Text::MediawikiFormat::_check_blocks;
175199 my $newtags = {
176 blocks => {foo => 1, bar => 1, baz => 1},
200 blocks => { foo => 1, bar => 1, baz => 1 },
177201 blockorder => [qw(bar baz)],
178202 };
179203 $cb->($newtags);
180204 my $warning = shift @warnings;
181 like $warning, qr/No order specified for blocks: foo\./,
182 '_check_blocks() should warn if block is not ordered';
205 like $warning, qr/No order specified for blocks: foo\./, '_check_blocks() should warn if block is not ordered';
183206
184207 $newtags->{blockorder} = ['baz'];
185208 $cb->($newtags);
186209 $warning = shift @warnings;
187210 ok $warning =~ /foo/ && $warning =~ /bar/, '... for all missing blocks'
188 or diag $warning;
211 or diag $warning;
+22
-27
t/bugs.t less more
99
1010 use_ok 'Text::MediawikiFormat', as => 'wf', process_html => 0;
1111
12 my $wikitext =<<WIKI;
12 my $wikitext = <<WIKI;
1313
1414
1515 * unordered
1818
1919 WIKI
2020
21 my $htmltext = eval { wf ($wikitext) };
21 my $htmltext = eval { wf($wikitext) };
2222
23 is $@, '',
24 'format() should throw no warnings for text starting with newlines';
23 is $@, '', 'format() should throw no warnings for text starting with newlines';
2524
26 like $htmltext, qr!<li>unordered</li>!,
27 'ensure that lists followed by paragraphs are included correctly';
25 like $htmltext, qr!<li>unordered</li>!, 'ensure that lists followed by paragraphs are included correctly';
2826
2927 package Baz;
3028 use Text::MediawikiFormat as => 'wf', process_html => 0;
4543 WIKI
4644
4745 my %format_tags = (
48 indent => qr/^(?:\t+|\s{4,}|(?=\*+))/,
49 blocks => { unordered => qr/^\s*\*+\s*/ },
50 nests => { unordered => 1 },
46 indent => qr/^(?:\t+|\s{4,}|(?=\*+))/,
47 blocks => { unordered => qr/^\s*\*+\s*/ },
48 nests => { unordered => 1 },
5149 );
5250
53 $htmltext = wf ($wikitext, \%format_tags);
51 $htmltext = wf( $wikitext, \%format_tags );
5452
5553 like $htmltext, qr/<li>foo<\/li>/, "first level of unordered list";
5654 like $htmltext, qr/<li>bar<\/li>/, "nested unordered lists OK";
5957 ## Check that blocks not in blockorder are not fatal
6058 ##
6159 %format_tags = (
62 blocks => {
60 blocks => {
6361 definition => qr/^:\s*/
6462 },
6563 definition => [ "<dl>\n", "</dl>\n", '<dt><dd>', "\n" ],
66 blockorder => [ 'definition' ],
64 blockorder => ['definition'],
6765 );
6866
6967 my $warning;
7068 local $SIG{__WARN__} = sub { $warning = shift };
71 eval { wf ($wikitext, \%format_tags) };
69 eval { wf( $wikitext, \%format_tags ) };
7270 is $@, '', 'format() should not die if a block is missing from blockorder';
7371 like $warning, qr/No order specified/, '... warning instead';
7472
7573 my $foo = 'x';
7674 $foo .= '' unless $foo =~ /x/;
77 my $html = wf ('test');
75 my $html = wf('test');
7876 is $html, "<p>test</p>\n", 'successful prior match should not whomp format()';
7977
80 $wikitext =<<'WIKI';
78 $wikitext = <<'WIKI';
8179 Here is some example code:
8280
8381 sub example_code
8987 Isn't it nice?
9088 WIKI
9189
92 $htmltext = wf ($wikitext, {blocks => {code => qr/^\t/}});
90 $htmltext = wf( $wikitext, { blocks => { code => qr/^\t/ } } );
9391
94 like $htmltext, qr!<pre>sub example_code[^<]+}\s*</pre>!m,
95 'pre tags should work';
92 like $htmltext, qr!<pre>sub example_code[^<]+}\s*</pre>!m, 'pre tags should work';
9693
97 like $htmltext, qr!^\tmy \(\$foo\)!m, '... not removing further indents';
94 like $htmltext, qr!^\tmy \(\$foo\)!m, '... not removing further indents';
9895
99 $wikitext =<<WIKI;
96 $wikitext = <<WIKI;
10097 CamelCase
10198 CamooseCase
10299 NOTCAMELCASE
103100 WIKI
104101
105 $htmltext = wf ($wikitext, {}, {implicit_links => 1});
102 $htmltext = wf( $wikitext, {}, { implicit_links => 1 } );
106103
107 like $htmltext, qr!<a href='CamelCase'>CamelCase</a>!,
108 'parse actual CamelCase words into links';
109 like $htmltext, qr!<a href='CamooseCase'>CamooseCase</a>!,
110 '... not repeating if using link as title';
111 like $htmltext, qr!^NOTCAMELCASE!m, '... but not words in all uppercase';
104 like $htmltext, qr!<a href='CamelCase'>CamelCase</a>!, 'parse actual CamelCase words into links';
105 like $htmltext, qr!<a href='CamooseCase'>CamooseCase</a>!, '... not repeating if using link as title';
106 like $htmltext, qr!^NOTCAMELCASE!m, '... but not words in all uppercase';
112107
113 my @processed = Text::MediawikiFormat::_nest_blocks ([]);
108 my @processed = Text::MediawikiFormat::_nest_blocks( [] );
114109 is @processed, 0, '_nest_blocks() should not autovivify empty blocks array';
+0
-20
t/developer/0-signature.t less more
0 #!perl
1
2 use strict;
3 use warnings;
4
5 use Test::More tests => 1;
6
7 SKIP: {
8 if (eval { require Module::Signature; 1 }) {
9 ok(Module::Signature::verify() == Module::Signature::SIGNATURE_OK()
10 => "Valid signature" );
11 }
12 else {
13 diag("Next time around, consider installing Module::Signature,\n".
14 "so you can verify the integrity of this distribution.\n");
15 skip("Module::Signature not installed", 1)
16 }
17 }
18
19 __END__
+3
-3
t/developer/pod-coverage.t less more
55 eval "use Test::Pod::Coverage 1.04";
66
77 plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage"
8 if $@;
8 if $@;
99
1010 plan tests => 2;
1111
12 pod_coverage_ok ('Text::MediawikiFormat');
13 pod_coverage_ok ('Text::MediawikiFormat::Blocks');
12 pod_coverage_ok('Text::MediawikiFormat');
13 pod_coverage_ok('Text::MediawikiFormat::Blocks');
+31
-35
t/embedded-links.t less more
1616 WIKI
1717
1818 {
19 my $htmltext = wf ($wikitext);
20 is $htmltext,
21 qq{<p>[[SuperLink|<a href='Description'>Desc</a> of the }
22 . qq{<a href='Link'>Link</a>]]</p>\n},
23 '...ignore embedded links by default';
19 my $htmltext = wf($wikitext);
20 is $htmltext,
21 qq{<p>[[SuperLink|<a href='Description'>Desc</a> of the } . qq{<a href='Link'>Link</a>]]</p>\n},
22 '...ignore embedded links by default';
2423 }
2524
2625 {
27 # Redefine the delimiters to something different.
28 my %tags = (extended_link_delimiters => [qw{[[ ]]}],
29 link => \&_make_html_link);
26 # Redefine the delimiters to something different.
27 my %tags = (
28 extended_link_delimiters => [qw{[[ ]]}],
29 link => \&_make_html_link
30 );
3031
31 my $htmltext = wf ($wikitext, \%tags);
32 is $htmltext,
33 qq{<p><a href='SuperLink'><a href='Description'>Desc</a> of the }
34 . qq{<a href='Link'>Link</a></a></p>\n},
35 '...processing all embedded links';
32 my $htmltext = wf( $wikitext, \%tags );
33 is $htmltext,
34 qq{<p><a href='SuperLink'><a href='Description'>Desc</a> of the } . qq{<a href='Link'>Link</a></a></p>\n},
35 '...processing all embedded links';
3636
37 sub _make_html_link
38 {
39 my ($link) = @_;
40 my ($href, $title) = split qr/\|/, $link, 2;
41 $title ||= $href;
42 return "<a href='$href'>$title</a>";
43 }
37 sub _make_html_link {
38 my ($link) = @_;
39 my ( $href, $title ) = split qr/\|/, $link, 2;
40 $title ||= $href;
41 return "<a href='$href'>$title</a>";
42 }
4443 }
4544
4645 TODO:
4746 {
48 # Art Henry's bug; but not sure it's really a bug
49 local $TODO = "Unsupported MediaWiki features.";
47 # Art Henry's bug; but not sure it's really a bug
48 local $TODO = "Unsupported MediaWiki features.";
5049
51 my %tags = (link => \&link_handler);
50 my %tags = ( link => \&link_handler );
5251
53 # Or with the link handler overridden.
54 my $htmltext = wf ($wikitext, \%tags);
55 is $htmltext,
56 "<p>Desc of the </p>\n",
57 '...and also work with a handler override.';
52 # Or with the link handler overridden.
53 my $htmltext = wf( $wikitext, \%tags );
54 is $htmltext, "<p>Desc of the </p>\n", '...and also work with a handler override.';
5855
59 sub link_handler
60 {
61 my ($link, $opts) = @_;
62 ($link, my $title) = split /\|/, $link, 2;
63 $title ||= $link;
64 return $title;
65 }
56 sub link_handler {
57 my ( $link, $opts ) = @_;
58 ( $link, my $title ) = split /\|/, $link, 2;
59 $title ||= $link;
60 return $title;
61 }
6662 }
+24
-39
t/explicit.t less more
44 use strict;
55 use warnings;
66
7 use Test::More tests => 14;
7 use Test::More tests => 13;
88 use Test::NoWarnings;
99 use Test::Warn;
1010
1111 use Text::MediawikiFormat as => 'wf', process_html => 0;
1212
13 my $wikitext =<<WIKI;
13 my $wikitext = <<WIKI;
1414
1515 [Ordinary extended link]
1616
2020
2121 WIKI
2222
23 my $htmltext = wf ($wikitext);
24 like $htmltext, qr!'Ordinary'>extended link</a>!m,
25 'extended links rendered correctly with default delimiters';
26 like $htmltext, qr!'http://nowhere\.com'>explicit URI</a>!m,
27 'explicit URIs rendered correctly with default delimiters';
23 my $htmltext = wf($wikitext);
24 like $htmltext, qr!'Ordinary'>extended link</a>!m, 'extended links rendered correctly with default delimiters';
25 like $htmltext, qr!'http://nowhere\.com'>explicit URI</a>!m, 'explicit URIs rendered correctly with default delimiters';
2826 like $htmltext, qr!Usemod%20extended%20link'>Usemod extended link</a>!m,
29 'Wiki URIs rendered correctly with default delimiters';
27 'Wiki URIs rendered correctly with default delimiters';
3028
3129 # Redefine the delimiters to the same thing again.
32 my %tags = (
33 extended_link_delimiters => qr/(\[(?:\[[^][]*\]|[^][]*)\])/,
34 );
30 my %tags = ( extended_link_delimiters => qr/(\[(?:\[[^][]*\]|[^][]*)\])/, );
3531
36 $htmltext = wf ($wikitext, \%tags);
37 like $htmltext, qr!'Ordinary'>extended link</a>!m,
38 'extended links rendered correctly with default delimiters';
39 like $htmltext, qr!'http://nowhere\.com'>explicit URI</a>!m,
40 'explicit URIs rendered correctly with default delimiters';
32 $htmltext = wf( $wikitext, \%tags );
33 like $htmltext, qr!'Ordinary'>extended link</a>!m, 'extended links rendered correctly with default delimiters';
34 like $htmltext, qr!'http://nowhere\.com'>explicit URI</a>!m, 'explicit URIs rendered correctly with default delimiters';
4135 like $htmltext, qr!Usemod%20extended%20link'>Usemod extended link</a>!m,
42 'Wiki URIs rendered correctly with default delimiters';
36 'Wiki URIs rendered correctly with default delimiters';
4337
4438 # Redefine the delimiters to something different.
45 %tags = (
46 extended_link_delimiters => [qw([ ])],
47 );
39 %tags = ( extended_link_delimiters => [qw([ ])], );
4840
49 $htmltext = wf ($wikitext, \%tags);
41 $htmltext = wf( $wikitext, \%tags );
5042
51 unlike $htmltext, qr!'Ordinary'>extended link</a>!m,
52 'extended links ignored with overridden delimiters';
53 unlike $htmltext, qr!'http://nowhere\.com'>explicit URI</a>!m,
54 'explicit URIs ignored with overridden delimiters';
55 like $htmltext, qr!Usemod extended link</a>[^\]]!m,
56 '...and new delimiters recognised';
43 unlike $htmltext, qr!'Ordinary'>extended link</a>!m, 'extended links ignored with overridden delimiters';
44 unlike $htmltext, qr!'http://nowhere\.com'>explicit URI</a>!m, 'explicit URIs ignored with overridden delimiters';
45 like $htmltext, qr!Usemod extended link</a>[^\]]!m, '...and new delimiters recognised';
5746
5847 # Make sure we handle empty delimiters
59 %tags = (
60 extended_link_delimiters => '',
61 );
48 %tags = ( extended_link_delimiters => '', );
6249
50 $htmltext = wf( $wikitext, \%tags );
6351
64 warning_like {$htmltext = wf ($wikitext, \%tags)}
65 {carped => [map {qr/^Ignoring/} (1..3)]},
66 "warn of empty extended_link_delimiters";
52 #warning_like {$htmltext = wf ($wikitext, \%tags)}
53 # {carped => [map {qr/^Ignoring/} (1..3)]},
54 # "warn of empty extended_link_delimiters";
6755
68 unlike $htmltext, qr!'Ordinary'>extended link</a>!m,
69 'extended links ignored with empty delimiters';
70 unlike $htmltext, qr!'http://nowhere\.com'>explicit URI</a>!m,
71 'explicit URIs ignored with empty delimiters';
72 unlike $htmltext, qr!Usemod extended link</a>[^\]]!m,
73 'Wiki URIs ignored with empty delimiters';
56 unlike $htmltext, qr!'Ordinary'>extended link</a>!m, 'extended links ignored with empty delimiters';
57 unlike $htmltext, qr!'http://nowhere\.com'>explicit URI</a>!m, 'explicit URIs ignored with empty delimiters';
58 unlike $htmltext, qr!Usemod extended link</a>[^\]]!m, 'Wiki URIs ignored with empty delimiters';
+11
-11
t/implicit.t less more
77 use Test::More tests => 4;
88 use Test::NoWarnings;
99
10 use Text::MediawikiFormat as => 'wf', prefix => 'rootdir/wiki.pl?page=',
11 process_html => 0;
10 use Text::MediawikiFormat
11 as => 'wf',
12 prefix => 'rootdir/wiki.pl?page=',
13 process_html => 0;
1214
13 my $wikitext =<<WIKI;
15 my $wikitext = <<WIKI;
1416 StudlyCaps
1517
1618 WIKI
1719
18 my $htmltext = wf ($wikitext);
20 my $htmltext = wf($wikitext);
1921 unlike $htmltext, qr!<a href='rootdir/wiki\.pl\?page=StudlyCaps'>!m,
20 'should create links from StudlyCaps if implicit_links is left alone';
22 'should create links from StudlyCaps if implicit_links is left alone';
2123
22 $htmltext = wf ($wikitext, {}, {implicit_links => 0});
23 unlike ($htmltext, qr!<a href='rootdir/wiki\.pl\?page=StudlyCaps'>!m,
24 '...and if implicit_links set to 0');
24 $htmltext = wf( $wikitext, {}, { implicit_links => 0 } );
25 unlike( $htmltext, qr!<a href='rootdir/wiki\.pl\?page=StudlyCaps'>!m, '...and if implicit_links set to 0' );
2526
26 $htmltext = wf ($wikitext, {}, {implicit_links => 1});
27 like ($htmltext, qr!<a href='rootdir/wiki\.pl\?page=StudlyCaps'>!m,
28 '...and if implicit_links set to 0');
27 $htmltext = wf( $wikitext, {}, { implicit_links => 1 } );
28 like( $htmltext, qr!<a href='rootdir/wiki\.pl\?page=StudlyCaps'>!m, '...and if implicit_links set to 0' );
+22
-25
t/kake.t less more
77 use Test::More tests => 8;
88 use Test::NoWarnings;
99
10 use Text::MediawikiFormat as => 'wikiformat', implicit_links => 1,
11 process_html => 0;
10 use Text::MediawikiFormat
11 as => 'wikiformat',
12 implicit_links => 1,
13 process_html => 0;
1214
13 my $wikitext = "
15 my $wikitext = "
1416 WikiTest
1517
1618 code: foo bar baz
1719
1820 ";
1921
20 my %format_tags = (
21 blocks => {code => qr/^code: /},
22 );
22 my %format_tags = ( blocks => { code => qr/^code: / }, );
2323
24 my $cooked = wikiformat ($wikitext, \%format_tags);
25 like $cooked, qr|<pre>foo bar baz\n</pre>|,
26 'unindented code markers should still work';
24 my $cooked = wikiformat( $wikitext, \%format_tags );
25 like $cooked, qr|<pre>foo bar baz\n</pre>|, 'unindented code markers should still work';
2726
2827 $wikitext = <<WIKI;
2928
3332 WIKI
3433
3534 %format_tags = (
36 indent => qr/^(?:\t+|\s{4,}|\*?(?=\*+))/,
37 blocks => {unordered => qr/^\s*\*+\s*/},
38 nests => {unordered => 1},
35 indent => qr/^(?:\t+|\s{4,}|\*?(?=\*+))/,
36 blocks => { unordered => qr/^\s*\*+\s*/ },
37 nests => { unordered => 1 },
3938 );
4039
4140 $cooked = wikiformat $wikitext, \%format_tags;
4948
5049 WIKI
5150
52 my @blocks = @{$Text::MediawikiFormat::tags{blockorder}};
51 my @blocks = @{ $Text::MediawikiFormat::tags{blockorder} };
5352 %format_tags = (
54 blocks => {definition => qr/^:\s*/},
55 indented => {definition => 0},
56 definition => ["<dl>\n", "</dl>\n", "<dt><dd>", "\n"],
57 blockorder => ['definition', @blocks],
53 blocks => { definition => qr/^:\s*/ },
54 indented => { definition => 0 },
55 definition => [ "<dl>\n", "</dl>\n", "<dt><dd>", "\n" ],
56 blockorder => [ 'definition', @blocks ],
5857 );
5958
6059 $cooked = wikiformat $wikitext, \%format_tags;
6160 like $cooked, qr/<dt><dd>boing/, 'definition list works';
6261
63 $wikitext =<<WIKITEXT;
62 $wikitext = <<WIKITEXT;
6463
6564 ==== Welcome ====
6665
7170 WIKITEXT
7271
7372 $ENV{SHOW} = 1;
74 $cooked = wikiformat $wikitext, {unformatted_blocks => [qw(code nowiki pre)]},
75 {prefix => 'wiki.pl?', implicit_links => 1};
73 $cooked = wikiformat $wikitext, { unformatted_blocks => [qw(code nowiki pre)] },
74 { prefix => 'wiki.pl?', implicit_links => 1 };
7675
77 like $cooked, qr|<h4>Welcome</h4>|, 'headings work';
78 like $cooked,
79 qr|<h4><a href='wiki.pl\?LinkInAHeader'>LinkInAHeader</a></h4>|,
80 '... links work in headers';
81 like $cooked, qr|<h4>Header with an = in</h4>|, '...headers may contain =';
76 like $cooked, qr|<h4>Welcome</h4>|, 'headings work';
77 like $cooked, qr|<h4><a href='wiki.pl\?LinkInAHeader'>LinkInAHeader</a></h4>|, '... links work in headers';
78 like $cooked, qr|<h4>Header with an = in</h4>|, '...headers may contain =';
+19
-27
t/lists-nested.t less more
99
1010 use_ok 'Text::MediawikiFormat', as => 'wf', process_html => 0 or exit;
1111
12 my $wikitext =<<END_HERE;
12 my $wikitext = <<END_HERE;
1313 * start of list
1414 * second line
1515 ** indented list
1616 * now back to the first
1717 END_HERE
1818
19 my $htmltext = wf ($wikitext);
20 like $htmltext, qr|second line<ul>.*?<li>indented|s,
21 'nested lists should start correctly';
22 like $htmltext, qr|indented list.*?</li>.*?</ul>|s,
23 '... and end correctly';
19 my $htmltext = wf($wikitext);
20 like $htmltext, qr|second line<ul>.*?<li>indented|s, 'nested lists should start correctly';
21 like $htmltext, qr|indented list.*?</li>.*?</ul>|s, '... and end correctly';
2422
25 $wikitext =<<END_HERE;
23 $wikitext = <<END_HERE;
2624 * 1
2725 * 2
2826 ** 2.1
3634 * 5
3735 END_HERE
3836
39 $htmltext = wf ($wikitext);
37 $htmltext = wf($wikitext);
4038
41 like $htmltext,
42 qr|<ul>\s*
39 like $htmltext, qr|<ul>\s*
4340 <li>1</li>\s*
4441 <li>2<ul>\s*
4542 <li>2\.1<ul>\s*
6057 </ul>\s*
6158 </li>\s*
6259 <li>5</li>\s*
63 </ul>|sx,
64 'nesting should be correct for multiple levels';
65 like $htmltext, qr|<li>4<|s,
66 'spaces should work instead of tabs';
67 like $htmltext,
68 qr|<li>4<ul>\s*<li>4.1<ul>\s*<li>4.1.1</li>\s*<li>4.1.2</li>\s*</ul>
69 \s*</li>|sx,
70 'nesting should be correct for spaces too';
71
60 </ul>|sx, 'nesting should be correct for multiple levels';
61 like $htmltext, qr|<li>4<|s, 'spaces should work instead of tabs';
62 like $htmltext, qr|<li>4<ul>\s*<li>4.1<ul>\s*<li>4.1.1</li>\s*<li>4.1.2</li>\s*</ul>
63 \s*</li>|sx, 'nesting should be correct for spaces too';
7264
7365 TODO: {
74 local $TODO = 'Dictionary lists not nesting correctly.';
66 local $TODO = 'Dictionary lists not nesting correctly.';
7567
7668 ###
7769 ### Dictionary Lists
7870 ###
79 $wikitext =<<END_HERE;
71 $wikitext = <<END_HERE;
8072 ; Term 1
8173 : Def 1.1
8274 :; Term 1.1.1 : Def 1.1.1.1
9284 ; Term 3 : Def 3.1
9385 END_HERE
9486
95 $htmltext = wf ($wikitext);
87 $htmltext = wf($wikitext);
9688
97 is $htmltext, '', 'dictionary lists nest correctly';
89 is $htmltext, '', 'dictionary lists nest correctly';
9890
99 $wikitext =<<END_HERE;
91 $wikitext = <<END_HERE;
10092 ; A
10193 : A.a
10294 :# A.a.1
108100 : A.b
109101 END_HERE
110102
111 $htmltext = wf ($wikitext);
103 $htmltext = wf($wikitext);
112104
113 is $htmltext, '<dl>
105 is $htmltext, '<dl>
114106 <dt>A</dt>
115107 <dd>A.a</dd>
116108 <ol>
130122 <dd>A.b</dd>
131123 </dl>
132124 ', 'lists nest correctly within dictionary lists';
133 };
125 }
+21
-28
t/lists-no-indent.t less more
99
1010 use Text::MediawikiFormat as => 'wf', process_html => 0;
1111
12 my $wikitext =<<WIKI;
12 my $wikitext = <<WIKI;
1313
1414 * This should be a list.
1515
2626
2727 WIKI
2828
29 my $htmltext = wf ($wikitext);
30 like $htmltext, qr!<li>This should be a list.</li>!m,
31 'unordered lists should render correctly';
32 like $htmltext, qr!<li>This should be an ordered list.</li>!m,
33 '...ordered lists too';
29 my $htmltext = wf($wikitext);
30 like $htmltext, qr!<li>This should be a list.</li>!m, 'unordered lists should render correctly';
31 like $htmltext, qr!<li>This should be an ordered list.</li>!m, '...ordered lists too';
3432
3533 # Redefine all the list regexps to what they were to start with.
3634 my %tags = (
3735 lists => {
3836 ordered => qr/^#\s*/,
3937 unordered => qr/^\*\s*/,
40 code => qr/^ /,
38 code => qr/^ /,
4139 },
4240 );
4341
44 $htmltext = wf ($wikitext, \%tags);
45 like $htmltext, qr!<li>This should be a list.</li>!m,
46 'unordered should remain okay when we redefine all list regexps';
47 like $htmltext, qr!<li>This should be an ordered list.</li>!m,
48 '...ordered lists too';
42 $htmltext = wf( $wikitext, \%tags );
43 like $htmltext, qr!<li>This should be a list.</li>!m, 'unordered should remain okay when we redefine all list regexps';
44 like $htmltext, qr!<li>This should be an ordered list.</li>!m, '...ordered lists too';
4945
5046 # Redefine again, set one of them to something different.
5147 %tags = (
5248 blocks => {
5349 ordered => qr/^#\s*/,
5450 unordered => qr/^!\s*/,
55 code => qr/^ /,
51 code => qr/^ /,
5652 },
5753 );
5854
59 $htmltext = wf ($wikitext, \%tags);
60 like $htmltext, qr!<li>But marked differently</li>!m,
61 'unordered should still work when redefined';
62 like $htmltext, qr!<li>This should be an ordered list.</li>!m,
63 '...ordered should be unaffected';
55 $htmltext = wf( $wikitext, \%tags );
56 like $htmltext, qr!<li>But marked differently</li>!m, 'unordered should still work when redefined';
57 like $htmltext, qr!<li>This should be an ordered list.</li>!m, '...ordered should be unaffected';
6458
6559 # Now try it without requiring an indent.
6660 %tags = (
67 indent => qr/^\s*/,
68 blocks => {
69 ordered => qr/^#\s*/,
70 unordered => qr/^\*\s*/,
71 code => qr/^ /,
72 },
73 indented => {unordered => 0},
61 indent => qr/^\s*/,
62 blocks => {
63 ordered => qr/^#\s*/,
64 unordered => qr/^\*\s*/,
65 code => qr/^ /,
66 },
67 indented => { unordered => 0 },
7468 );
7569
76 $htmltext = wf ($wikitext, \%tags);
77 like $htmltext, qr!<li># But not indented!m,
78 'redefining a list type to require no indent should work';
70 $htmltext = wf( $wikitext, \%tags );
71 like $htmltext, qr!<li># But not indented!m, 'redefining a list type to require no indent should work';
+10
-17
t/lists.t less more
88 use Test::NoWarnings;
99
1010 use_ok 'Text::MediawikiFormat', as => 'wf', process_html => 0 or exit;
11 ok exists $Text::MediawikiFormat::tags{blockorder},
12 'T:MF should have a blockorder entry in %tags';
11 ok exists $Text::MediawikiFormat::tags{blockorder}, 'T:MF should have a blockorder entry in %tags';
1312
1413 # isan ARRAY
15 isa_ok $Text::MediawikiFormat::tags{blockorder}, 'ARRAY',
16 '...and it should be an array';
14 isa_ok $Text::MediawikiFormat::tags{blockorder}, 'ARRAY', '...and it should be an array';
1715
18 like join(' ', @{$Text::MediawikiFormat::tags{blockorder}}),
19 qr/^code/,
20 '...and code should come before everything';
16 like join( ' ', @{ $Text::MediawikiFormat::tags{blockorder} } ), qr/^code/, '...and code should come before everything';
2117
22 my $wikitext =<<END_HERE;
18 my $wikitext = <<END_HERE;
2319 * first list item
2420 * second list item
2521 * list item with a [[Wiki Link]]
2622 END_HERE
2723
28 my $htmltext = wf ($wikitext);
24 my $htmltext = wf($wikitext);
2925
30 like $htmltext, qr!<li>first list item!,
31 'lists should be able to start on the first line of text';
32 like $htmltext, qr!href='Wiki%20Link'!,
33 'list item content should be formatted';
26 like $htmltext, qr!<li>first list item!, 'lists should be able to start on the first line of text';
27 like $htmltext, qr!href='Wiki%20Link'!, 'list item content should be formatted';
3428
3529 ###
3630 ### Dictionary Lists
3731 ###
38 $wikitext =<<END_HERE;
32 $wikitext = <<END_HERE;
3933 ; Term 1 : definition 1.1
4034 : definition 1.2
4135 ; Term 2
4640 : indented 2
4741 END_HERE
4842
49 $htmltext = wf ($wikitext);
43 $htmltext = wf($wikitext);
5044
5145 is $htmltext, '<dl>
5246 <dt>Term 1</dt>
6054 <dd>indented 1</dd>
6155 <dd>indented 2</dd>
6256 </dl>
63 ',
64 'dictionary lists format correctly';
57 ', 'dictionary lists format correctly';
+15
-19
t/merge-hash.t less more
77 use Test::More tests => 9;
88 use Test::NoWarnings;
99
10 use_ok( 'Text::MediawikiFormat' ) or exit;
10 use_ok('Text::MediawikiFormat') or exit;
1111
1212 my $full = { foo => { bar => 'baz' } };
1313 my $empty = {};
1616 my $empty_flat = {};
1717 my $zero = { foo => 0, bar => { baz => 0 } };
1818
19 $nonempty = Text::MediawikiFormat::_merge_hashes ($full, $nonempty);
20 is_deeply $nonempty, {foo => {a => 'b', bar => 'baz'}},
21 "merge should work when all keys in from exist in to";
19 $nonempty = Text::MediawikiFormat::_merge_hashes( $full, $nonempty );
20 is_deeply $nonempty, { foo => { a => 'b', bar => 'baz' } }, "merge should work when all keys in from exist in to";
2221 $full->{foo}->{bar} = 'boo';
23 is_deeply $nonempty, {foo => {a => 'b', bar => 'baz'}},
24 "merge should copy subhashes";
22 is_deeply $nonempty, { foo => { a => 'b', bar => 'baz' } }, "merge should copy subhashes";
2523
26 $empty_flat = Text::MediawikiFormat::_merge_hashes ($full_flat, $empty_flat);
27 is_deeply $empty_flat, $full_flat,
28 '... in flat case when keys exist in from but not in to';
24 $empty_flat = Text::MediawikiFormat::_merge_hashes( $full_flat, $empty_flat );
25 is_deeply $empty_flat, $full_flat, '... in flat case when keys exist in from but not in to';
2926
30 $empty = Text::MediawikiFormat::_merge_hashes ($full, $empty);
31 is_deeply $empty, $full,
32 '... in non-flat case when keys exist in but not in to';
27 $empty = Text::MediawikiFormat::_merge_hashes( $full, $empty );
28 is_deeply $empty, $full, '... in non-flat case when keys exist in but not in to';
3329
3430 $empty = {};
35 $empty = Text::MediawikiFormat::_merge_hashes ($zero, $empty);
31 $empty = Text::MediawikiFormat::_merge_hashes( $zero, $empty );
3632 is_deeply $empty, $zero, '...and when value is zero but defined';
3733
38 my $regexer = {a => "regex"};
39 my $arrayer = {a => ["X", "Y", "Z"]};
34 my $regexer = { a => "regex" };
35 my $arrayer = { a => [ "X", "Y", "Z" ] };
4036 my $merged;
41 $merged = Text::MediawikiFormat::_merge_hashes ($regexer, $arrayer);
42 is_deeply $merged, {a => "regex"}, "regexes should replace arrays";
43 $merged = Text::MediawikiFormat::_merge_hashes ($arrayer, $regexer);
44 is_deeply $merged, {a => ["X", "Y", "Z"]}, "...and vice versa";
37 $merged = Text::MediawikiFormat::_merge_hashes( $regexer, $arrayer );
38 is_deeply $merged, { a => "regex" }, "regexes should replace arrays";
39 $merged = Text::MediawikiFormat::_merge_hashes( $arrayer, $regexer );
40 is_deeply $merged, { a => [ "X", "Y", "Z" ] }, "...and vice versa";
+12
-14
t/tag-override-use-as.t less more
99
1010 use Text::MediawikiFormat as => 'wf', process_html => 0;
1111
12 my $wikitext =<<WIKI;
12 my $wikitext = <<WIKI;
1313
1414 * This should be a list.
1515
2323
2424 WIKI
2525
26 my %format_tags = (blocks => {unordered => qr/^!\s*/});
27
28 my $htmltext = wf ($wikitext, \%format_tags);
29 like ($htmltext, qr!<li>But marked differently</li>!m,
30 'redefining a list type works with use as');
26 my %format_tags = ( blocks => { unordered => qr/^!\s*/ } );
27
28 my $htmltext = wf( $wikitext, \%format_tags );
29 like( $htmltext, qr!<li>But marked differently</li>!m, 'redefining a list type works with use as' );
3130
3231 %format_tags = (
3332 indent => qr//,
34 blocks => {
35 ordered => qr/^#\s*/,
36 unordered => qr/^\*\s*/
33 blocks => {
34 ordered => qr/^#\s*/,
35 unordered => qr/^\*\s*/
3736 },
38 indented => {unordered => 0},
39 );
37 indented => { unordered => 0 },
38 );
4039
41 $htmltext = wf ($wikitext, \%format_tags);
42 like ($htmltext, qr!<li>\* But not indented!m,
43 'redefining a list type to require no indent works with use as');
40 $htmltext = wf( $wikitext, \%format_tags );
41 like( $htmltext, qr!<li>\* But not indented!m, 'redefining a list type to require no indent works with use as' );
+30
-36
t/tag-override.t less more
99
1010 use Text::MediawikiFormat as => 'wf', process_html => 0;
1111
12 my $wikitext =<<WIKI;
12 my $wikitext = <<WIKI;
1313
1414 * This should be a list.
1515
2020
2121 WIKI
2222
23 my $htmltext = wf ($wikitext);
24 like ($htmltext, qr!<li>This should be a list.</li>!m,
25 'unordered lists should be rendered correctly');
26 like ($htmltext, qr!<li>This should be an ordered list.</li>!m,
27 '...and ordered lists too');
23 my $htmltext = wf($wikitext);
24 like( $htmltext, qr!<li>This should be a list.</li>!m, 'unordered lists should be rendered correctly' );
25 like( $htmltext, qr!<li>This should be an ordered list.</li>!m, '...and ordered lists too' );
2826
2927 # Redefine all the list regexps to what they were to start with.
3028 my %tags = (
3533 },
3634 );
3735
38 $htmltext = wf ($wikitext, \%tags);
39 like ($htmltext, qr!<li>This should be a list.</li>!m,
40 'unordered should remain okay when we redefine all list regexps');
41 like ($htmltext, qr!<li>This should be an ordered list.</li>!m,
42 '... and so should ordered');
36 $htmltext = wf( $wikitext, \%tags );
37 like(
38 $htmltext,
39 qr!<li>This should be a list.</li>!m,
40 'unordered should remain okay when we redefine all list regexps'
41 );
42 like( $htmltext, qr!<li>This should be an ordered list.</li>!m, '... and so should ordered' );
4343
4444 # Redefine again, set one of them to something different.
4545 %tags = (
5050 },
5151 );
5252
53 $htmltext = wf ($wikitext, \%tags);
54 like ($htmltext, qr!<li>But marked differently</li>!m,
55 'unordered should still work when redefined');
56 like ($htmltext, qr!<li>This should be an ordered list.</li>!m,
57 '...and ordered should be unaffected');
53 $htmltext = wf( $wikitext, \%tags );
54 like( $htmltext, qr!<li>But marked differently</li>!m, 'unordered should still work when redefined' );
55 like( $htmltext, qr!<li>This should be an ordered list.</li>!m, '...and ordered should be unaffected' );
5856
5957 # Now try redefining just one list type.
60 %tags = (
61 blocks => {unordered => qr/^!\s*/},
58 %tags = ( blocks => { unordered => qr/^!\s*/ }, );
59
60 $htmltext = wf( $wikitext, \%tags );
61 like(
62 $htmltext,
63 qr!<li>This is like the default unordered list</li>!m,
64 'redefining just one list type should work for that type'
6265 );
63
64 $htmltext = wf ($wikitext, \%tags);
65 like ($htmltext, qr!<li>This is like the default unordered list</li>!m,
66 'redefining just one list type should work for that type');
67 like ($htmltext, qr!<li>This should be an ordered list.</li>!m,
68 '...and should not affect other types too');
66 like( $htmltext, qr!<li>This should be an ordered list.</li>!m, '...and should not affect other types too' );
6967
7068 # now test overriding strong and emphasized tags
7169 # don't use // to mark emphasized tags unless you /like/ this lookbehind
7573 );
7674
7775 $wikitext = 'this is *strong*, /emphasized/, and */emphasized strong/*';
78 $htmltext = wf ($wikitext, \%tags);
76 $htmltext = wf( $wikitext, \%tags );
7977
80 like( $htmltext, qr!<strong>strong</strong>!, '... overriding strong tag' );
81 like( $htmltext, qr!<em>emphasized</em>!, '... overriding emphasized tag' );
82 like( $htmltext, qr!<strong><em>em.+ng</em></strong>!,
83 '... and both at once' );
78 like( $htmltext, qr!<strong>strong</strong>!, '... overriding strong tag' );
79 like( $htmltext, qr!<em>emphasized</em>!, '... overriding emphasized tag' );
80 like( $htmltext, qr!<strong><em>em.+ng</em></strong>!, '... and both at once' );
8481
8582 # Test redefining just one list type after using import with a list definition.
8683 package Bar;
8784 Text::MediawikiFormat->import(
88 as => 'wf',
85 as => 'wf',
8986 blocks => {
9087 unordered => qr/^!\s*/
9188 },
9289 process_html => 0,
9390 );
9491
95 $htmltext = wf ("!1. Ordered list\n! Unordered list",
96 {blocks => {ordered => qr/^\s*!([\d]+)\.\s*/}}, {});
97 ::like ($htmltext, qr!<li>Ordered list</li>!m,
98 'redefining a single list type after import should work for that type');
99 ::like ($htmltext, qr!<li>Unordered list</li>!m,
100 '...and also for a different type defined on import');
92 $htmltext = wf( "!1. Ordered list\n! Unordered list", { blocks => { ordered => qr/^\s*!([\d]+)\.\s*/ } }, {} );
93 ::like( $htmltext, qr!<li>Ordered list</li>!m, 'redefining a single list type after import should work for that type' );
94 ::like( $htmltext, qr!<li>Unordered list</li>!m, '...and also for a different type defined on import' );