6 use Maintainers qw/%Modules/;
12 # generate the module changes for the Perl you are currently building
13 ./perl Porting/corelist-perldelta.pl
15 # generate a diff between the corelist sections of two perldelta* files:
16 perl Porting/corelist-perldelta.pl --mode=check 5.017001 5.017002 <perl5172delta.pod
20 corelist-perldelta.pl is a bit schizophrenic. The part to generate the
21 new Perldelta text does not need Algorithm::Diff, but wants to be
22 run with the freshly built Perl.
24 The part to check the diff wants to be run with a Perl that has an up-to-date
25 L<Module::CoreList>, but needs the outside L<Algorithm::Diff>.
27 Ideally, the program will be split into two separate programs, one
28 to generate the text and one to show the diff between the
29 corelist sections of the last perldelta and the next perldelta.
34 new => qr/New Modules and Pragma(ta)?/,
35 updated => qr/Updated Modules and Pragma(ta)?/,
36 removed => qr/Removed Modules and Pragma(ta)?/,
40 new => 'New Modules and Pragmata',
41 updated => 'Updated Modules and Pragmata',
42 removed => 'Removed Modules and Pragmata',
47 #--------------------------------------------------------------------------#
50 my ($mod, $old_v, $new_v) = @_;
52 say "L<$mod> $new_v has been added to the Perl core.\n";
56 my ($mod, $old_v, $new_v) = @_;
58 say "L<$mod> has been upgraded from version $old_v to $new_v.\n";
59 if ( $deprecated->{$mod} ) {
60 say "NOTE: L<$mod> is deprecated and may be removed from a future version of Perl.\n";
65 my ($mod, $old_v, $new_v) = @_;
67 say "C<$mod> has been removed from the Perl core. Prior version was $old_v.\n";
70 sub generate_section {
71 my ($title, $item_sub, @mods ) = @_;
74 say "=head2 $title\n";
77 for my $tuple ( sort { lc($a->[0]) cmp lc($b->[0]) } @mods ) {
78 my ($mod,$old_v,$new_v) = @$tuple;
79 $old_v //= q('undef');
80 $new_v //= q('undef');
81 $item_sub->($mod, $old_v, $new_v);
87 #--------------------------------------------------------------------------#
90 my %opt = (mode => 'generate');
93 'mode|m:s', # 'generate', 'check'
96 # by default, compare latest two version in CoreList;
97 my @versions = sort keys %Module::CoreList::version;
98 my ($old, $new) = (shift @ARGV, shift @ARGV);
99 $old ||= $versions[-2];
100 $new ||= $versions[-1];
102 if ( $opt{mode} eq 'generate' ) {
103 do_generate($old => $new);
105 elsif ( $opt{mode} eq 'check' ) {
106 do_check(\*ARGV, $old => $new);
109 die "Unrecognized mode '$opt{mode}'\n";
116 my ($old, $new) = @_;
117 my $corelist = \%Module::CoreList::version;
119 $deprecated = $Module::CoreList::deprecated{$new};
121 my (@new,@deprecated,@removed,@pragmas,@modules);
123 # %Modules defines what is currently in core
124 for my $k ( keys %Modules ) {
125 next unless exists $corelist->{$new}{$k};
126 my $old_ver = $corelist->{$old}{$k};
127 my $new_ver = $corelist->{$new}{$k};
128 # in core but not in last corelist
129 if ( ! exists $corelist->{$old}{$k} ) {
130 push @new, [$k, undef, $new_ver];
132 # otherwise just pragmas or modules
134 my $old_ver = $corelist->{$old}{$k};
135 my $new_ver = $corelist->{$new}{$k};
136 next unless defined $old_ver && defined $new_ver && $old_ver ne $new_ver;
137 my $tuple = [ $k, $old_ver, $new_ver ];
139 push @pragmas, $tuple;
142 push @modules, $tuple;
147 # in old corelist, but not this one => removed
148 # N.B. This is exhaustive -- not just what's in %Modules, so modules removed from
149 # distributions will show up here, too. Some person will have to review to see what's
150 # important. That's the best we can do without a historical Maintainers.pl
151 for my $k ( keys %{ $corelist->{$old} } ) {
152 if ( ! exists $corelist->{$new}{$k} ) {
153 push @removed, [$k, $corelist->{$old}{$k}, undef];
157 return (\@new, \@removed, \@pragmas, \@modules);
161 my ($old, $new) = @_;
162 my ($added, $removed, $pragmas, $modules) = corelist_delta($old => $new);
164 generate_section($titles{new}, \&added, @{ $added });
165 generate_section($titles{updated}, \&updated, @{ $pragmas }, @{ $modules });
166 generate_section($titles{removed}, \&removed, @{ $removed });
170 my ($in, $old, $new) = @_;
172 my $delta = DeltaParser->new($in);
173 my ($added, $removed, $pragmas, $modules) = corelist_delta($old => $new);
175 for my $ck (['new', $delta->new_modules, $added],
176 ['removed', $delta->removed_modules, $removed],
177 ['updated', $delta->updated_modules, [@{ $modules }, @{ $pragmas }]]) {
178 my @delta = @{ $ck->[1] };
179 my @corelist = sort { lc $a->[0] cmp lc $b->[0] } @{ $ck->[2] };
181 printf $ck->[0] . ":\n";
183 require Algorithm::Diff;
184 my $diff = Algorithm::Diff->new(map {
185 [map { join q{ } => grep defined, @{ $_ } } @{ $_ }]
186 } \@delta, \@corelist);
188 while ($diff->Next) {
191 if (!$diff->Items(2)) {
192 printf "%d,%dd%d\n", $diff->Get(qw( Min1 Max1 Max2 ));
193 } elsif(!$diff->Items(1)) {
194 printf "%da%d,%d\n", $diff->Get(qw( Max1 Min2 Max2 ));
197 printf "%d,%dc%d,%d\n", $diff->Get(qw( Min1 Max1 Min2 Max2 ));
199 print "< $_\n" for $diff->Items(1);
201 print "> $_\n" for $diff->Items(2);
210 use Pod::Simple::SimpleTree;
213 my ($class, $input) = @_;
215 my $self = bless {} => $class;
217 my $parsed_pod = Pod::Simple::SimpleTree->new->parse_file($input)->root;
218 splice @{ $parsed_pod }, 0, 2; # we don't care about the document structure,
219 # just the nodes within it
221 $self->_parse_delta($parsed_pod);
226 for my $k (keys %sections) {
228 my $m = "${k}_modules";
229 *$m = sub { $_[0]->{$m} };
233 my ($self, $pod) = @_;
236 my ($t, $s) = @{ $_ };
238 # Keep the section title if it has one:
239 if( $s->[0]->[0] eq 'head2' ) {
240 #warn "Keeping section title '$s->[0]->[2]'";
241 $titles{ $t } = $s->[0]->[2]
245 $self->${\"_parse_${t}_section"}($s)
247 my $s = $self->_look_for_section($pod => $sections{$_})
248 or die "failed to parse $_ section";
252 for my $s (keys %sections) {
253 my $m = "${s}_modules";
255 $self->{$m} = [sort {
256 lc $a->[0] cmp lc $b->[0]
263 sub _parse_new_section {
264 my ($self, $section) = @_;
266 $self->{new_modules} = $self->_parse_section($section => sub {
269 my ($first, $second) = @{ $el }[2, 3];
270 my ($ver) = $second =~ /(\d[^\s]+)\s+has\s+been/;
272 return [ $first->[2], undef, $ver ];
278 sub _parse_updated_section {
279 my ($self, $section) = @_;
281 $self->{updated_modules} = $self->_parse_section($section => sub {
284 my ($first, $second) = @{ $el }[2, 3];
285 my $module = $first->[2];
286 my ($old, $new) = $second =~
287 /from\s+(?:version\s+)?(\d[^\s]+)\s+to\s+(\d[^\s]+?)\.?$/;
289 warn "Unable to extract old or new version of $module from perldelta"
290 if !defined $old || !defined $new;
292 return [ $module, $old, $new ];
298 sub _parse_removed_section {
299 my ($self, $section) = @_;
300 $self->{removed_modules} = $self->_parse_section($section => sub {
303 my ($first, $second) = @{ $el }[2, 3];
304 my ($old) = $second =~ /was\s+(\d[^\s]+?)\.?$/;
306 return [ $first->[2], $old, undef ];
313 my ($self, $section, $parser) = @_;
315 my $items = $self->_look_down($section => sub {
317 return unless ref $el && $el->[0] =~ /^item-/
318 && @{ $el } > 2 && ref $el->[2];
319 return unless $el->[2]->[0] eq 'C';
324 return [map { $parser->($_) } @{ $items }];
328 my ($self, $pod, $predicate) = @_;
332 while (my $el = shift @pod) {
333 push @l, $el if $predicate->($el);
337 unshift @pod, @el if @el;
341 return @l ? \@l : undef;
344 sub _look_for_section {
345 my ($self, $pod, $section) = @_;
348 $self->_look_for_range($pod,
351 my ($heading) = $el->[0] =~ /^head(\d)$/;
352 my $f = $heading && $el->[2] =~ /^$section/;
353 $level = $heading if $f && !$level;
358 $el->[0] =~ /^head(\d)$/ && $1 <= $level;
363 sub _look_for_range {
364 my ($self, $pod, $start_predicate, $stop_predicate) = @_;
367 for my $el (@{ $pod }) {
369 return \@l if $stop_predicate->($el);
372 next unless $start_predicate->($el);