Skip to content

Commit f2b5442

Browse files
bookbook
committed
add a script that merges all devel deltas into the final one
For now, the script simply copies the content of each relevant section into the same one in the master document (pod/perldelta.pod). It will die when encountering an unexpected =head1 header.
1 parent 147d5f1 commit f2b5442

File tree

1 file changed

+199
-0
lines changed

1 file changed

+199
-0
lines changed

‎Porting/merge-deltas.pl‎

Lines changed: 199 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,199 @@
1+
#!perl
2+
use v5.36;
3+
use Pod::Simple::SimpleTree;
4+
5+
# POD NAVIGATION SUBROUTINES
6+
7+
sub header_pos ( $tree, $level, $title, $pos = 0 ) {
8+
while ( $pos < @$tree ) {
9+
next
10+
unless ref( $tree->[$pos] ) eq 'ARRAY'
11+
&& $tree->[$pos][0] eq "head$level";
12+
return $pos if $tree->[$pos][2] eq $title;
13+
}
14+
continue { $pos++ }
15+
return; # not found
16+
}
17+
18+
sub next_header_pos ( $tree, $level, $pos = 0 ) {
19+
$pos++;
20+
while ( $pos < @$tree ) {
21+
next
22+
unless ref( $tree->[$pos] ) eq 'ARRAY';
23+
next unless $tree->[$pos][0] =~ /\Ahead([1-4])\z/;
24+
next if $1 > $level;
25+
last if $1 < $level;
26+
return $pos;
27+
}
28+
continue { $pos++ }
29+
return; # not found
30+
}
31+
32+
sub find_pos_in ( $master, $delta, $title ) {
33+
return
34+
map header_pos( $_, 1, $title ),
35+
$master, $delta;
36+
}
37+
38+
# copy the whole section content
39+
sub copy_section ( $master, $title, $delta ) {
40+
my ( $master_pos, $delta_pos ) = find_pos_in( $master, $delta, $title );
41+
42+
# find the end of the section in the delta
43+
my $end_pos = next_header_pos( $delta, 1, $delta_pos ) - 1;
44+
45+
# inject the whole section from the delta
46+
splice @$master, $master_pos + 1,
47+
0, $delta->@[ $delta_pos + 1 .. $end_pos ];
48+
}
49+
50+
# map each section to an action
51+
my %ACTION_FOR = (
52+
'NAME' => 'skip',
53+
'DESCRIPTION' => 'skip',
54+
'Notice' => 'copy',
55+
'Core Enhancements' => 'copy',
56+
'Security' => 'copy',
57+
'Incompatible Changes' => 'copy',
58+
'Deprecations' => 'copy',
59+
'Performance Enhancements' => 'copy',
60+
'Modules and Pragmata' => 'skip',
61+
'Documentation' => 'copy',
62+
'Diagnostics' => 'copy',
63+
'Utility Changes' => 'copy',
64+
'Configuration and Compilation' => 'copy',
65+
'Testing' => 'copy',
66+
'Platform Support' => 'copy',
67+
'Internal Changes' => 'copy',
68+
'Selected Bug Fixes' => 'copy',
69+
'Known Problems' => 'copy',
70+
'Errata From Previous Releases' => 'copy',
71+
'Obituary' => 'copy',
72+
'Acknowledgements' => 'skip',
73+
'Reporting Bugs' => 'skip',
74+
'Give Thanks' => 'skip',
75+
'SEE ALSO' => 'skip',
76+
);
77+
78+
# NOTE: A Pod::Simple::SimpleTree "tree" is really just a list of
79+
# directives. The only parts that are really tree-like / recursive are
80+
# the list directives, and pod formatting codes.
81+
82+
sub as_pod ( $tree ) {
83+
return $tree unless ref $tree; # simple string
84+
state $handler = {
85+
Document => sub ( $name, $attr, @nodes ) {
86+
return map( as_pod($_), @nodes), "=cut\n";
87+
},
88+
Para => sub ( $name, $attr, @nodes ) {
89+
return map( as_pod($_), @nodes ), "\n\n";
90+
},
91+
Verbatim => sub ( $name, $attr, @nodes ) {
92+
return map( as_pod($_), @nodes ), "\n\n";
93+
},
94+
X => sub ( $name, $attr, @nodes ) {
95+
my ( $open, $spacer, $close ) =
96+
$attr->{'~bracket_count'}
97+
? (
98+
'<' x $attr->{'~bracket_count'},
99+
' ',
100+
'>' x $attr->{'~bracket_count'}
101+
)
102+
: ( '<', '', '>' );
103+
return "$name$open$spacer",
104+
map( as_pod($_), @nodes ),
105+
"$spacer$close";
106+
},
107+
L => sub ( $name, $attr, @nodes ) {
108+
return "$name<$attr->{raw}>";
109+
},
110+
# TODO: =begin / =for
111+
over => sub ( $name, $attr, @nodes ) {
112+
return "=over",
113+
$attr->{'~orig_content'} && " $attr->{'~orig_content'}", "\n\n",
114+
map( as_pod($_), @nodes ), "=back\n\n";
115+
},
116+
item => sub ( $name, $attr, @nodes ) {
117+
return "=item ",
118+
$attr->{'~orig_content'} ? "$attr->{'~orig_content'}\n\n" : '',
119+
map( as_pod($_), @nodes ), "\n\n";
120+
},
121+
'' => sub ( $name, $attr, @nodes ) {
122+
return "=$name", @nodes && ' ', map( as_pod($_), @nodes ), "\n\n";
123+
},
124+
};
125+
my ( $directive, $attr, @nodes ) = @$tree;
126+
my $name =
127+
exists $handler->{$directive} ? $directive
128+
: $directive =~ /\Aover-/ ? 'over'
129+
: $directive =~ /\Aitem-/ ? 'item'
130+
: length($directive) == 1 ? 'X'
131+
: '';
132+
return join '', $handler->{$name}->( $directive, $attr, @nodes );
133+
}
134+
135+
# Note: the parser can only be used *once* per file
136+
sub tree_for ($string) {
137+
my $parser = Pod::Simple::SimpleTree->new;
138+
$parser->keep_encoding_directive(1);
139+
$parser->preserve_whitespace(1);
140+
$parser->accept_targets('*'); # for & begin/end
141+
$parser->_output_is_for_JustPod(1); # for ~bracket_count
142+
$parser->parse_string_document($string)->root;
143+
}
144+
145+
sub merge_into ( $master, $delta, $file ) {
146+
147+
# loop over the =head1 sections
148+
for my $title (
149+
map $_->[2], # grab the title
150+
grep ref eq 'ARRAY' && $_->[0] eq 'head1', # of the =head1
151+
@$delta # of the delta
152+
)
153+
{
154+
die "Unexpected section '=head1 $title' in $file\n"
155+
unless exists $ACTION_FOR{$title};
156+
next if $ACTION_FOR{$title} eq 'skip';
157+
copy_section( $master, $title, $delta );
158+
}
159+
}
160+
161+
sub slurp { return do { local @ARGV = @_; local $/; <> } }
162+
163+
# MAIN PROGRAM
164+
165+
sub main (@argv) {
166+
167+
# compute the version
168+
my ($version) = `git describe` =~ /\Av(5\.[0-9]+)/g;
169+
die "$version does not look like a devel Perl version\n"
170+
unless $version =~ /\A5\.[0-9]{1,2}[13579]\z/;
171+
172+
# the current, unfinished, delta will be used
173+
# as the master to produce the final document
174+
my $final_delta = 'pod/perldelta.pod';
175+
my $master = tree_for( slurp($final_delta) );
176+
177+
# loop over all the development deltas
178+
my $tag_devel = $version =~ tr/.//dr;
179+
for my $file_tree (
180+
map [ $_->[0], tree_for( slurp( $_->[0] ) ) ],
181+
sort { $b->[1] <=> $a->[1] }
182+
map [ $_, m{pod/perl$tag_devel([0-9]+)delta\.pod}g ],
183+
glob "pod/perl$tag_devel*delta.pod"
184+
)
185+
{
186+
my ( $file, $delta ) = @$file_tree;
187+
merge_into( $master, $delta, $file );
188+
}
189+
190+
# save the result
191+
open my $fh, '>', $final_delta
192+
or die "Can't open $final_delta for writing: $!";
193+
print $fh as_pod($master);
194+
195+
return 0;
196+
}
197+
198+
# make it easier to test
199+
exit main( @ARGV ) unless caller;

0 commit comments

Comments
 (0)