Skip to content

Commit e6654a9

Browse files
bookbook
committed
rework the tests to generate and compare pod
The test documents are described using short keys, and the actual POD document is generated by assemble_pod. A template like: [qw( head1:Security xxx_security security1 security2 )], will produce a document with the preamble, a security section and the postamble. The test function merges each delta into the master, and compares the result with the expected document.
1 parent 11325a0 commit e6654a9

File tree

1 file changed

+154
-51
lines changed

1 file changed

+154
-51
lines changed

‎t/porting/merge-delta.t‎

Lines changed: 154 additions & 51 deletions
Original file line numberDiff line numberDiff line change
@@ -4,78 +4,181 @@ use Test2::V0;
44
# load the script
55
do('./Porting/merge-deltas.pl') or die $@ || $!;
66

7-
# helper function
8-
sub head2_slice ( $tree, $title ) {
9-
my $begin = next_header_pos( $tree, 2, header_pos( $tree, 1, $title ) );
10-
my $end = next_header_pos( $tree, 1, $begin ) - 1;
11-
return [ $tree->@[ $begin .. $end ] ];
12-
}
13-
14-
# test data
7+
# test snippets
158
my %pod = do {
169
local $/;
1710
my ( undef, @kv ) = split /^# (.*)\n/m, <DATA>;
1811
@kv;
1912
};
20-
$pod{master} = slurp('Porting/perldelta_template.pod');
13+
14+
# grab text snippets from the template
15+
# and double-check they're not empty
16+
{
17+
my $template = slurp('Porting/perldelta_template.pod');
18+
@pod{qw( preamble postamble )} =
19+
$template =~ /\A(.*?)^=head1 Notice.*(^=head1 Acknowledgements.*)\Z/gsm;
20+
is( $pod{$_}, L(), "$_ is not empty" ) for qw( preamble postamble );
21+
for (qw( Notice Security Documentation Diagnostics Testing )) {
22+
( $pod{"xxx_\L$_"} ) = $template =~ /^=head1 $_\n\n(.*?)^=/gsm;
23+
is( $pod{"xxx_\L$_"}, L(), "xxx_\L$_\E is not empty" );
24+
}
25+
for ( 'New Documentation', 'Changes to Existing Documentation' ) {
26+
my $key = lc join '_', xxx => tr/ /_/r;
27+
( $pod{$key} ) = $template =~ /^=head2 $_\n\n(.*)^=/gsm;
28+
is( $pod{$key}, L(), "$key is not empty" );
29+
}
30+
}
31+
32+
$pod{"item_bullet_xxx"} = "=item *\n\nXXX\n\n";
33+
$pod{"item_bullet$_"} = "=item *\n\nItem number $_\n\n" for 1 .. 5;
34+
$pod{"item_text_xxx"} = "=item XXX-item\n\nXXX\n\n";
35+
$pod{"item_text$_"} = "=item Number $_\n\nText number $_\n\n" for 1 .. 5;
36+
37+
# helper function to build pod from a short description
38+
sub assemble_pod {
39+
state $format = {
40+
head1 => "=head1 %s\n\n",
41+
head2 => "=head2 %s\n\n",
42+
over => "=over 4\n\n%s=back\n\n",
43+
};
44+
return join '', map exists $pod{$_}
45+
? $pod{$_}
46+
: /:/ ? do {
47+
my ( $fmt, @items ) = split /:/;
48+
sprintf $format->{$fmt}, join '', map $pod{$_} // $_, @items;
49+
}
50+
: $_,
51+
'preamble', shift->@*, 'postamble';
52+
}
53+
54+
# test data
55+
my @tests = ( # name, expected, master, deltas...
56+
[ 'skip (empty)', [''], [''], [''] ],
57+
[
58+
'skip',
59+
[''],
60+
[''],
61+
[
62+
'head1:Modules and Pragmata', # this one is skipped
63+
'xxx_notice', 'xxx_security' # random content
64+
]
65+
],
66+
[
67+
'copy',
68+
[qw( head1:Notice notice xxx_notice )],
69+
[qw( head1:Notice xxx_notice )],
70+
[qw( head1:Notice notice )],
71+
],
72+
[
73+
'head2 (single)',
74+
[qw( head1:Security xxx_security security1 )],
75+
[qw( head1:Security xxx_security )],
76+
[qw( head1:Security xxx_security security1 )],
77+
],
78+
[
79+
'head2 (2-in-1)',
80+
[qw( head1:Security xxx_security security1 security2 )],
81+
[qw( head1:Security xxx_security )],
82+
[qw( head1:Security xxx_security security1 security2 )],
83+
],
84+
[
85+
'head2 (multiple)',
86+
[qw( head1:Security xxx_security security1 security2 )],
87+
[qw( head1:Security xxx_security )],
88+
[qw( head1:Security xxx_security security1 )],
89+
[qw( head1:Security xxx_security security2 )],
90+
],
91+
[
92+
'head2 (multiple reverse)',
93+
[qw( head1:Security xxx_security security2 security1 )],
94+
[qw( head1:Security xxx_security )],
95+
[qw( head1:Security xxx_security security2 )],
96+
[qw( head1:Security xxx_security security1 )],
97+
],
98+
[
99+
'copy + head2',
100+
[
101+
qw( head1:Notice notice xxx_notice head1:Security xxx_security security1 )
102+
],
103+
[qw( head1:Notice xxx_notice head1:Security xxx_security )],
104+
[qw( head1:Notice notice )],
105+
[qw(head1:Security xxx_security security1 )],
106+
],
107+
[
108+
'item (single)',
109+
[qw( head1:Testing xxx_testing over:item_bullet1:item_bullet_xxx )],
110+
[qw( head1:Testing xxx_testing over:item_bullet_xxx )],
111+
[qw( head1:Testing xxx_testing over:item_bullet1 )],
112+
],
113+
[
114+
'item (2-in-1)',
115+
[
116+
qw( head1:Testing xxx_testing over:item_bullet1:item_bullet2:item_bullet_xxx )
117+
],
118+
[qw( head1:Testing xxx_testing over:item_bullet_xxx )],
119+
[qw( head1:Testing xxx_testing over:item_bullet1:item_bullet2 )],
120+
],
121+
[
122+
'item (multiple)',
123+
[
124+
qw( head1:Testing xxx_testing ),
125+
'over:item_bullet1:item_bullet2:item_bullet3:item_bullet4:item_bullet_xxx'
126+
],
127+
[qw( head1:Testing xxx_testing over:item_bullet_xxx )],
128+
[qw( head1:Testing xxx_testing over:item_bullet1:item_bullet2 )],
129+
[qw( head1:Testing xxx_testing over:item_bullet3:item_bullet4 )],
130+
],
131+
[
132+
'item (multiple reverse)',
133+
[
134+
qw( head1:Testing xxx_testing ),
135+
'over:item_bullet3:item_bullet4:item_bullet1:item_bullet2:item_bullet_xxx'
136+
],
137+
[qw( head1:Testing xxx_testing over:item_bullet_xxx )],
138+
[qw( head1:Testing xxx_testing over:item_bullet3:item_bullet4 )],
139+
[qw( head1:Testing xxx_testing over:item_bullet1:item_bullet2 )],
140+
],
141+
);
21142

22143
# tree_for:
23144
# just a single test: we're not testing Pod::Simple::SimpleTree
24145
is(
25-
tree_for( $pod{'NAME section'} ),
146+
tree_for( $pod{security1} ),
26147
[
27148
Document => { start_line => 1 },
28-
[ head1 => { start_line => 1 }, 'NAME' ],
29-
[ Para => { start_line => 3 }, 'some text' ]
149+
[ head2 => { start_line => 1 }, 'CVE-2025-12345' ],
150+
[ Para => { start_line => 3 }, 'Some CVE was fixed.' ],
151+
[ Para => { start_line => 5 }, 'Found by some person.' ],
30152
],
31-
'tree_for on NAME section'
153+
'tree_for (basic POD)'
32154
);
33155

34-
# as_pod: round trips
35-
is( as_pod( tree_for( $pod{$_} ) ), $pod{$_}, "$_ POD round trips" )
36-
for sort keys %pod;
37-
38-
# merge_info
39-
my ( $master, $delta, $title );
40-
41-
# merge_into: skips (e.g. NAME)
42-
$title = 'NAME';
43-
$master = tree_for( $pod{master} );
44-
my $master_pod = as_pod( $pod{master} ); # compute it before munging $master
45-
merge_into( $master, tree_for( $pod{$title} ), $title );
46-
is( as_pod($master), $master_pod, 'merge_into( skip )' );
47-
48-
# merge_into: head2 section (e.g. Security)
49-
$title = 'Security';
50-
$master = tree_for( $pod{master} );
51-
$delta = tree_for( $pod{$title} );
52-
merge_into( $master, $delta, $title );
53-
is(
54-
head2_slice( $master, $title ),
55-
head2_slice( $delta, $title ),
56-
'merge_into( head2 )'
57-
);
156+
# merge_into:
157+
# this is the meat of our tests
158+
for my $t (@tests) {
159+
my ( $mesg, $expected_spec, $master_spec, @delta_specs ) = @$t;
160+
my $master = tree_for( assemble_pod($master_spec) );
161+
merge_into( $master, $_, $mesg )
162+
for map tree_for( assemble_pod($_) ), reverse @delta_specs;
163+
is( as_pod($master), assemble_pod($expected_spec), $mesg );
164+
}
58165

59166
done_testing;
60167

61168
__DATA__
62-
# NAME section
63-
=head1 NAME
64-
65-
some text
66-
67-
=cut
68-
# Security
69-
=head1 Security
169+
# notice
170+
My important notice.
70171
71-
Some security blurb.
172+
# security1
173+
=head2 CVE-2025-12345
72174
73-
=head2 [CVE-1999-12345] Heap buffer overflow vulnerability
175+
Some CVE was fixed.
74176
75-
A heap buffer overflow vulnerability was discovered in Perl.
177+
Found by some person.
76178
77-
=head1 Acknowledgements
179+
# security2
180+
=head2 Some other security fix
78181
79-
ACK
182+
Was Perl pwnd again? Looks like.
80183
81-
=cut
184+
# empty

0 commit comments

Comments
 (0)