1#!perl 2 3use strict; 4use warnings; 5 6use Test::More tests => 35; 7 8my $module = 'Text::WikiFormat'; 9use_ok( $module ) or exit; 10 11can_ok( $module, 'start_block' ); 12my $text =<<END_WIKI; 13= heading = 14 15 * unordered item 16 1. ordered item 17 18 some code 19 20a normal paragraph 21 22END_WIKI 23 24sub fetchsub 25{ 26 return $module->can( $_[0] ); 27} 28 29my $tags = \%Text::WikiFormat::tags; 30local *Text::WikiFormat::tags = $tags; 31 32my $sb = fetchsub( 'start_block' ); 33my ($result) = $sb->( '= heading =', $tags ); 34 35ok( $result->isa( 'Text::WikiFormat::Block::header' ), 36 'start_block() should find headings' ) or diag "... it's a $result"; 37 38is( $result->level(), 0, '... at the correct level' ); 39 40($result) = $sb->( ' * unordered item', $tags ); 41 42ok( $result->isa( 'Text::WikiFormat::Block::unordered' ), 43 'start_block() should find unordered lists' ) or diag "... it's a $result"; 44is( $result->level(), 2, '... at the correct level' ); 45is( join('', $result->text() ), 46 'unordered item', '... with the correct text' ); 47 48($result) = $sb->( ' 6. ordered item', $tags ); 49 50ok( $result->isa( 'Text::WikiFormat::Block::ordered' ), 51 'start_block() should find ordered lists' ) or diag "... it's a $result"; 52is( $result->level(), 2, '... at the correct level' ); 53is( join('', $result->text()), 54 'ordered item', '... with the correct text' ); 55 56($result) = $sb->( ' some code', $tags ); 57 58ok( $result->isa( 'Text::WikiFormat::Block::code' ), 59 'start_block() should find code' ) or diag "... it's a $result"; 60is( $result->level(), 0, '... at the correct level' ); 61is( join('', $result->text()), 62 "some code", '... with the correct text' ); 63 64($result) = $sb->( 'paragraph', $tags ); 65 66ok( $result->isa( 'Text::WikiFormat::Block::paragraph' ), 67 'start_block() should find paragraph' ) or diag "... it's a $result"; 68is( $result->level(), 0, '... at the correct level' ); 69is( join('', $result->text() ), 70 'paragraph', '... with the correct text' ); 71 72can_ok( $module, 'merge_blocks' ); 73my $mb = fetchsub( 'merge_blocks' ); 74my @result = $mb->([ 75 map { Text::WikiFormat::new_block( @$_ ) } 76 [ 'code', text => 'a', level => 1 ], 77 [ 'code', text => 'b', level => 1 ], 78]); 79is( @result, 1, 'merge_blocks() should merge identical blocks together' ); 80is_deeply( $result[0]{text}, [qw( a b )], '... merging their text' ); 81 82@result = $mb->([ 83 map { Text::WikiFormat::new_block( @$_ ) } 84 [ 'unordered', text => 'foo', level => 1 ], 85 [ 'unordered', text => 'bar', level => 1 ], 86], $tags); 87is( @result, 1, '... merging unordered blocks' ); 88is_deeply( $result[0]{text}, [qw( foo bar)], '... and their text' ); 89 90@result = $mb->([ 91 map { Text::WikiFormat::new_block( @$_ ) } 92 [ 'ordered', text => 'foo', level => 2 ], 93 [ 'ordered', text => 'bar', level => 3 ], 94], $tags); 95is( @result, 2, '... not merging blocks at different levels' ); 96 97can_ok( $module, 'process_blocks' ); 98my $pb = fetchsub( 'process_blocks' ); 99my $nb = fetchsub( 'nest_blocks' ); 100my @opts = ( tags => $tags, opts => {} ); 101my @blocks = map { Text::WikiFormat::new_block( @$_, @opts ) } 102 [ 'header', text => [ '' ], level => 0, 103 args => [ '==', 'my header' ] ], 104 [ 'end', text => [ '' ], level => 0, @opts ], 105 [ 'paragraph', text => [qw( my lines of text )], 106 args => [], level => 0 ], 107 [ 'end', text => [ '' ], level => 0, @opts ], 108 [ 'ordered', text => [qw( my ordered lines ), 109 Text::WikiFormat::new_block( 110 'unordered', text => [qw( my unordered lines )], level => 3, 111 args => [], @opts 112 ), 113 ], level => 2, args => [] ]; 114 115# it's hard to fake these up; this may be a bad test 116$blocks[2]{args} = [ [], [], [] ]; 117$blocks[4]{args} = [ [ 2 ], [ 3 ], [ 5 ] ]; 118$blocks[4]{text}[3]{args} = [ [], [], [] ]; 119 120@result = $pb->( \@blocks, $tags ); 121 122is( @result, 1, 'process_blocks() should return processed text' ); 123$result = $result[0]; 124like( $result, qr!<h2>my header</h2>!, '... marking header' ); 125like( $result, qr!<p>my<br />.+text</p>\n!s, '... paragraph' ); 126like( $result, qr!<li value="2">my</li>.+5">lines!s, '... ordered list' ); 127like( $result, qr!<ul>\n<li>my</li>!m, '... and unordered list' ); 128like( $result, qr!</li>\n</ul>\n</li>\n</ol>!, '... nesting properly' ); 129 130my $f = fetchsub( 'format' ); 131my $fullresult = $f->(<<END_WIKI, $tags); 132== my header == 133 134my 135lines 136of 137text 138 139 2. my 140 3. ordered 141 5. lines 142 * my 143 * unordered 144 * lines 145END_WIKI 146 147is( $fullresult, $result, 'format() should give same results' ); 148 149$fullresult = $f->(<<END_WIKI, $tags); 150= heading = 151 152 * aliases can expire 153 * use the Expires directive 154 * no messages sent after the expiration date 155 * aliases can be closed 156 * use the Closed directive 157 * messages allowed only from people on the list 158 * aliases can auto-add people 159 * use the Auto-add directive 160 * anyone in the Cc line is added to the alias 161 * they won't get duplicates 162 * makes "just reply to alias" easier 163 164END_WIKI 165 166like( $fullresult, qr!expire<ul>!, 'nested list should start immediately' ); 167like( $fullresult, qr!date</li>\n</ul>!, '... ending after last nested item' ); 168 169can_ok( $module, 'check_blocks' ); 170 171my @warnings; 172local $SIG{__WARN__} = sub { 173 push @warnings, shift; 174}; 175 176my $cb = \&Text::WikiFormat::check_blocks; 177my $newtags = { 178 blocks => { foo => 1, bar => 1, baz => 1 }, 179 blockorder => [qw( bar baz )], 180}; 181$cb->( $newtags ); 182my $warning = shift @warnings; 183like( $warning, qr/No order specified for blocks 'foo'/, 184 'check_blocks() should warn if block is not ordered' ); 185 186$newtags->{blockorder} = [ 'baz' ]; 187$cb->( $newtags ); 188$warning = shift @warnings; 189ok( $warning =~ /foo/ && $warning =~ /bar/, '... for all missing blocks' ) 190 or diag( $warning ); 191