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