|
| 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 | +# POD GENERATION SUBROUTINES |
| 39 | + |
| 40 | +# NOTE: A Pod::Simple::SimpleTree "tree" is really just a list of |
| 41 | +# directives. The only parts that are really tree-like / recursive are |
| 42 | +# the list directives, and pod formatting codes. |
| 43 | + |
| 44 | +sub as_pod ( $tree ) { |
| 45 | + return $tree unless ref $tree; # simple string |
| 46 | + state $handler = { |
| 47 | + Document => sub ( $name, $attr, @nodes ) { |
| 48 | + return map( as_pod($_), @nodes), "=cut\n"; |
| 49 | + }, |
| 50 | + Para => sub ( $name, $attr, @nodes ) { |
| 51 | + return map( as_pod($_), @nodes ), "\n\n"; |
| 52 | + }, |
| 53 | + Verbatim => sub ( $name, $attr, @nodes ) { |
| 54 | + return map( as_pod($_), @nodes ), "\n\n"; |
| 55 | + }, |
| 56 | + X => sub ( $name, $attr, @nodes ) { |
| 57 | + my ( $open, $spacer, $close ) = |
| 58 | + $attr->{'~bracket_count'} |
| 59 | + ? ( |
| 60 | + '<' x $attr->{'~bracket_count'}, |
| 61 | + ' ', |
| 62 | + '>' x $attr->{'~bracket_count'} |
| 63 | + ) |
| 64 | + : ( '<', '', '>' ); |
| 65 | + return "$name$open$spacer", |
| 66 | + map( as_pod($_), @nodes ), |
| 67 | + "$spacer$close"; |
| 68 | + }, |
| 69 | + L => sub ( $name, $attr, @nodes ) { |
| 70 | + return "$name<$attr->{raw}>"; |
| 71 | + }, |
| 72 | + # TODO: =begin / =for |
| 73 | + over => sub ( $name, $attr, @nodes ) { |
| 74 | + return "=over", |
| 75 | + $attr->{'~orig_content'} && " $attr->{'~orig_content'}", "\n\n", |
| 76 | + map( as_pod($_), @nodes ), "=back\n\n"; |
| 77 | + }, |
| 78 | + item => sub ( $name, $attr, @nodes ) { |
| 79 | + return "=item ", |
| 80 | + $attr->{'~orig_content'} ? "$attr->{'~orig_content'}\n\n" : '', |
| 81 | + map( as_pod($_), @nodes ), "\n\n"; |
| 82 | + }, |
| 83 | + '' => sub ( $name, $attr, @nodes ) { |
| 84 | + return "=$name", @nodes && ' ', map( as_pod($_), @nodes ), "\n\n"; |
| 85 | + }, |
| 86 | + }; |
| 87 | + my ( $directive, $attr, @nodes ) = @$tree; |
| 88 | + my $name = |
| 89 | + exists $handler->{$directive} ? $directive |
| 90 | + : $directive =~ /\Aover-/ ? 'over' |
| 91 | + : $directive =~ /\Aitem-/ ? 'item' |
| 92 | + : length($directive) == 1 ? 'X' |
| 93 | + : ''; |
| 94 | + return join '', $handler->{$name}->( $directive, $attr, @nodes ); |
| 95 | +} |
| 96 | + |
| 97 | +sub pod_excerpt ( $tree, $begin, $end ) { |
| 98 | + return as_pod( [ Document => {}, $tree->@[ $begin .. $end ] ] ); |
| 99 | +} |
| 100 | + |
| 101 | +# CONTENT MANIPULATION SUBROUTINES |
| 102 | + |
| 103 | +sub copy_section ( $master, $title, $delta ) { |
| 104 | + my ( $master_pos, $delta_pos ) = find_pos_in( $master, $delta, $title ); |
| 105 | + |
| 106 | + # find the end of the section in the delta |
| 107 | + my $end_pos = next_header_pos( $delta, 1, $delta_pos ) - 1; |
| 108 | + |
| 109 | + # inject the whole section from the delta |
| 110 | + splice @$master, $master_pos + 1, |
| 111 | + 0, $delta->@[ $delta_pos + 1 .. $end_pos ]; |
| 112 | +} |
| 113 | + |
| 114 | +sub remove_identical ( $master, $title, $template ) { |
| 115 | + my ( $master_pos, $template_pos ) = |
| 116 | + find_pos_in( $master, $template, $title ); |
| 117 | + |
| 118 | + # find the end of the section in both |
| 119 | + my $master_end_pos = next_header_pos( $master, 1, $master_pos ) - 1; |
| 120 | + my $template_end_pos = next_header_pos( $template, 1, $template_pos ) - 1; |
| 121 | + |
| 122 | + # drop the section from the master if it's identical |
| 123 | + # to that in the template |
| 124 | + if ( pod_excerpt( $master, $master_pos, $master_end_pos ) eq |
| 125 | + pod_excerpt( $template, $template_pos, $template_end_pos ) ) |
| 126 | + { |
| 127 | + splice @$master, $master_pos, $master_end_pos - $master_pos + 1; |
| 128 | + } |
| 129 | +} |
| 130 | + |
| 131 | +# map each section to an action |
| 132 | +my %ACTION_FOR = ( |
| 133 | + 'NAME' => 'skip', |
| 134 | + 'DESCRIPTION' => 'skip', |
| 135 | + 'Notice' => 'copy', |
| 136 | + 'Core Enhancements' => 'copy', |
| 137 | + 'Security' => 'copy', |
| 138 | + 'Incompatible Changes' => 'copy', |
| 139 | + 'Deprecations' => 'copy', |
| 140 | + 'Performance Enhancements' => 'copy', |
| 141 | + 'Modules and Pragmata' => 'skip', |
| 142 | + 'Documentation' => 'copy', |
| 143 | + 'Diagnostics' => 'copy', |
| 144 | + 'Utility Changes' => 'copy', |
| 145 | + 'Configuration and Compilation' => 'copy', |
| 146 | + 'Testing' => 'copy', |
| 147 | + 'Platform Support' => 'copy', |
| 148 | + 'Internal Changes' => 'copy', |
| 149 | + 'Selected Bug Fixes' => 'copy', |
| 150 | + 'Known Problems' => 'copy', |
| 151 | + 'Errata From Previous Releases' => 'copy', |
| 152 | + 'Obituary' => 'copy', |
| 153 | + 'Acknowledgements' => 'skip', |
| 154 | + 'Reporting Bugs' => 'skip', |
| 155 | + 'Give Thanks' => 'skip', |
| 156 | + 'SEE ALSO' => 'skip', |
| 157 | +); |
| 158 | + |
| 159 | +# HELPER SUBROUTINES |
| 160 | + |
| 161 | +# Note: the parser can only be used *once* per file |
| 162 | +sub tree_for ($string) { |
| 163 | + my $parser = Pod::Simple::SimpleTree->new; |
| 164 | + $parser->keep_encoding_directive(1); |
| 165 | + $parser->preserve_whitespace(1); |
| 166 | + $parser->accept_targets('*'); # for & begin/end |
| 167 | + $parser->_output_is_for_JustPod(1); # for ~bracket_count |
| 168 | + $parser->parse_string_document($string)->root; |
| 169 | +} |
| 170 | + |
| 171 | +sub loop_head1 ( $master, $tree, $file, $cb ) { |
| 172 | + for my $title ( |
| 173 | + map $_->[2], # grab the title |
| 174 | + grep ref eq 'ARRAY' && $_->[0] eq 'head1', # of the =head1 |
| 175 | + @$tree # of the tree |
| 176 | + ) |
| 177 | + { |
| 178 | + die "Unexpected section '=head1 $title' in $file\n" |
| 179 | + unless exists $ACTION_FOR{$title}; |
| 180 | + next if $ACTION_FOR{$title} eq 'skip'; |
| 181 | + $cb->( $master, $title, $tree ); |
| 182 | + } |
| 183 | +} |
| 184 | + |
| 185 | +sub slurp ($file) { |
| 186 | + open my $fh, '<:utf8', $file |
| 187 | + or die "Can't open $file for reading: $!"; |
| 188 | + return do { local $/; <$fh> }; |
| 189 | +} |
| 190 | + |
| 191 | +# MAIN PROGRAM |
| 192 | + |
| 193 | +sub main (@argv) { |
| 194 | + |
| 195 | + # compute the version |
| 196 | + my ($version) = `git describe` =~ /\Av(5\.[0-9]+)/g; |
| 197 | + die "$version does not look like a devel Perl version\n" |
| 198 | + unless $version =~ /\A5\.[0-9]{1,2}[13579]\z/; |
| 199 | + |
| 200 | + # the current, unfinished, delta will be used |
| 201 | + # as the master to produce the final document |
| 202 | + my $final_delta = 'pod/perldelta.pod'; |
| 203 | + my $master = tree_for( slurp($final_delta) ); |
| 204 | + |
| 205 | + # loop over all the development deltas |
| 206 | + my $tag_devel = $version =~ tr/.//dr; |
| 207 | + for my $file_tree ( |
| 208 | + map [ $_->[0], tree_for( slurp( $_->[0] ) ) ], |
| 209 | + sort { $b->[1] <=> $a->[1] } |
| 210 | + map [ $_, m{pod/perl$tag_devel([0-9]+)delta\.pod}g ], |
| 211 | + glob "pod/perl$tag_devel*delta.pod" |
| 212 | + ) |
| 213 | + { |
| 214 | + my ( $file, $delta ) = @$file_tree; |
| 215 | + loop_head1( |
| 216 | + $master, $delta, $file, |
| 217 | + sub ( $master, $title, $delta ) { |
| 218 | + copy_section( $master, $title, $delta ); |
| 219 | + } |
| 220 | + ); |
| 221 | + } |
| 222 | + |
| 223 | + # find all sections in the template identical to those |
| 224 | + # in the master and remove them (from the master) |
| 225 | + my $template_file = 'Porting/perldelta_template.pod'; |
| 226 | + my $template = tree_for( slurp($template_file) ); |
| 227 | + loop_head1( |
| 228 | + $master, $template, $template_file, |
| 229 | + sub ( $master, $title, $template ) { |
| 230 | + remove_identical( $master, $title, $template ); |
| 231 | + } |
| 232 | + ); |
| 233 | + |
| 234 | + # save the result |
| 235 | + open my $fh, '>:utf8', $final_delta |
| 236 | + or die "Can't open $final_delta for writing: $!"; |
| 237 | + print $fh as_pod($master); |
| 238 | + |
| 239 | + return 0; |
| 240 | +} |
| 241 | + |
| 242 | +# make it easier to test |
| 243 | +exit main( @ARGV ) unless caller; |
0 commit comments