Porting/pod_lib.pl

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use File::Find;
   5
   6 =head1 NAME
   7
   8 Porting/pod_lib.pl - functions for building and installing POD
   9
  10 =head1 SYNOPSIS
  11
  12     require './Porting/pod_lib.pl';
  13
  14 =cut
  15
  16 =head1 DESCRIPTION
  17
  18 This program, when C<require>d into other programs in the Perl 5 core
  19 distribution, provides functions useful during building and, secondarily,
  20 testing.
  21
  22 As of this writing, the functions in this program are used in these other
  23 programs:
  24
  25     installman
  26     installperl
  27     pod/buildtoc
  28     pod/perl.pod
  29     Porting/new-perldelta.pl
  30     Porting/pod_rules.pl
  31
  32 Note:  Since these functions are used during the Perl build process, they must
  33 work with F<miniperl>.  That necessarily implies that these functions must not
  34 rely on XS modules, either directly or indirectly (e.g., C<autodie>).
  35
  36 =head1 SUBROUTINES
  37
  38 =head2 C<my_die()>
  39
  40 =over 4
  41
  42 =item * Purpose
  43
  44 Exit from a process with an error code and a message.
  45
  46 =item * Arguments
  47
  48 List of arguments to be passed with the error message.  Example:
  49
  50     close $fh or my_die("close 'utils.lst': $!");
  51
  52 =item * Return Value
  53
  54 Exit code C<255>.
  55
  56 =item * Comment
  57
  58 Prints C<ABORTED> to STDERR.
  59
  60 =back
  61
  62 =cut
  63
  64 # In some situations, eg cross-compiling, we get run with miniperl, so we can't use Digest::MD5
  65 my $has_md5;
  66 BEGIN {
  67     use Carp;
  68     $has_md5 = eval { require Digest::MD5; Digest::MD5->import('md5');  1; };
  69 }
  70
  71
  72 # make it clearer when we haven't run to completion, as we can be quite
  73 # noisy when things are working ok
  74
  75 sub my_die {
  76     print STDERR "$0: ", @_;
  77     print STDERR "\n" unless $_[-1] =~ /\n\z/;
  78     print STDERR "ABORTED\n";
  79     exit 255;
  80 }
  81
  82 =head2 C<open_or_die()>
  83
  84 =over 4
  85
  86 =item * Purpose
  87
  88 Opens a file or fails if it cannot.
  89
  90 =item * Arguments
  91
  92 String holding filename to be opened.  Example:
  93
  94     $fh = open_or_die('utils.lst');
  95
  96 =item * Return Value
  97
  98 Handle to opened file.
  99
 100 =back
 101
 102 =cut
 103
 104 sub open_or_die {
 105     my $filename = shift;
 106     open my $fh, '<', $filename or my_die "Can't open $filename: $!";
 107     return $fh;
 108 }
 109
 110 =head2 C<slurp_or_die()>
 111
 112 =over 4
 113
 114 =item * Purpose
 115
 116 Read the contents of a file into memory as a single string.
 117
 118 =item * Arguments
 119
 120 String holding name of file to be read into memory.
 121
 122     $olddelta = slurp_or_die('pod/perldelta.pod');
 123
 124 =item * Return Value
 125
 126 String holding contents of file.
 127
 128 =back
 129
 130 =cut
 131
 132 sub slurp_or_die {
 133     my $filename = shift;
 134     my $fh = open_or_die($filename);
 135     binmode $fh;
 136     local $/;
 137     my $contents = <$fh>;
 138     die "Can't read $filename: $!" unless defined $contents and close $fh;
 139     return $contents;
 140 }
 141
 142 =head2 C<write_or_die()>
 143
 144 =over 4
 145
 146 =item * Purpose
 147
 148 Write out a string to a file.
 149
 150 =item * Arguments
 151
 152 List of two arguments:  (i) String holding name of file to be written to; (ii)
 153 String holding contents to be written.
 154
 155     write_or_die($olddeltaname, $olddelta);
 156
 157 =item * Return Value
 158
 159 Implicitly returns true value upon success.
 160
 161 =back
 162
 163 =cut
 164
 165 sub write_or_die {
 166     my ($filename, $contents) = @_;
 167     open my $fh, '>', $filename or die "Can't open $filename for writing: $!";
 168     binmode $fh;
 169     print $fh $contents or die "Can't write to $filename: $!";
 170     close $fh or die "Can't close $filename: $!";
 171 }
 172
 173 =head2 C<verify_contiguous()>
 174
 175 =over 4
 176
 177 =item * Purpose
 178
 179 Verify that a file contains exactly one contiguous run of lines which matches
 180 the passed in pattern. C<croak()>s if the pattern is not found, or found in
 181 more than one place.
 182
 183 =item * Arguments
 184
 185 =over 4
 186
 187 =item * Name of file
 188
 189 =item * Contents of file
 190
 191 =item * Pattern of interest
 192
 193 =item * Name to report on error
 194
 195 =back
 196
 197 =item * Return Value
 198
 199 The contents of the file, with C<qr/\0+/> substituted for the pattern.
 200
 201 =back
 202
 203 =cut
 204
 205 sub verify_contiguous {
 206     my ($name, $content, $re, $what) = @_;
 207     require Carp;
 208     $content =~ s/$re/\0/g;
 209     my $sections = () = $content =~ m/\0+/g;
 210     Carp::croak("$0: $name contains no $what") if $sections < 1;
 211     Carp::croak("$0: $name contains discontiguous $what") if $sections > 1;
 212     return $content;
 213 }
 214
 215 =head2 C<process()>
 216
 217 =over 4
 218
 219 =item * Purpose
 220
 221 Read a file from disk, pass the contents to the callback, and either update
 222 the file on disk (if changed) or generate TAP output to confirm that the
 223 version on disk is up to date. C<die>s if the file contains any C<NUL> bytes.
 224 This permits the callback routine to use C<NUL> bytes as placeholders while
 225 manipulating the file's contents.
 226
 227 =item * Arguments
 228
 229 =over 4
 230
 231 =item * Description for use in error messages
 232
 233 =item * Name of file
 234
 235 =item * Callback
 236
 237 Passed description and file contents, should return updated file contents.
 238
 239 =item * Test number
 240
 241 If defined, generate TAP output to C<STDOUT>. If defined and false, generate
 242 an unnumbered test. Otherwise this is the test number in the I<ok> line.
 243
 244 =item * Verbose flag
 245
 246 If true, generate verbose output.
 247
 248 =back
 249
 250 =item * Return Value
 251
 252 Does not return anything.
 253
 254 =back
 255
 256 =cut
 257
 258 sub process {
 259     my ($desc, $filename, $callback, $test, $verbose) = @_;
 260
 261     print "Now processing $filename\n" if $verbose;
 262     my $orig = slurp_or_die($filename);
 263     my_die "$filename contains NUL bytes" if $orig =~ /\0/;
 264
 265     my $new = $callback->($desc, $orig);
 266
 267     if (defined $test) {
 268         printf "%s%s # $filename is up to date\n",
 269             ($new eq $orig ? 'ok' : 'not ok'), ($test ? " $test" : '');
 270         return;
 271     } elsif ($new eq $orig) {
 272         print "Was not modified\n"
 273             if $verbose;
 274         return;
 275     }
 276
 277     my $mode = (stat $filename)[2];
 278     my_die "Can't stat $filename: $!"
 279         unless defined $mode;
 280     rename $filename, "$filename.old"
 281         or my_die "Can't rename $filename to $filename.old: $!";
 282
 283     write_or_die($filename, $new);
 284     chmod $mode & 0777, $filename or my_die "can't chmod $mode $filename: $!";
 285 }
 286
 287 =head2 C<pods_to_install()>
 288
 289 =over 4
 290
 291 =item * Purpose
 292
 293 Create a lookup table holding information about PODs to be installed.
 294
 295 =item * Arguments
 296
 297 None.
 298
 299 =item * Return Value
 300
 301 Reference to a hash with a structure like this:
 302
 303     $found = {
 304       'MODULE' => {
 305         'CPAN::Bundle' => 'lib/CPAN/Bundle.pm',
 306         'Locale::Codes::Script_Retired' =>
 307             'lib/Locale/Codes/Script_Retired.pm',
 308         'Pod::Simple::DumpAsText' =>
 309             'lib/Pod/Simple/DumpAsText.pm',
 310         # ...
 311         'Locale::Codes::LangVar' =>
 312             'lib/Locale/Codes/LangVar.pod'
 313       },
 314       'PRAGMA' => {
 315         'fields' => 'lib/fields.pm',
 316         'subs' => 'lib/subs.pm',
 317         # ...
 318       },
 319
 320 =item * Comment
 321
 322 Broadly speaking, the function assembles a list of all F<.pm> and F<.pod>
 323 files in the distribution and then excludes certain files from installation.
 324
 325 =back
 326
 327 =cut
 328
 329 sub pods_to_install {
 330     # manpages not to be installed
 331     my %do_not_install = map { ($_ => 1) }
 332         qw(Pod::Functions XS::APItest XS::Typemap);
 333     $do_not_install{"ExtUtils::XSSymSet"} = 1
 334         unless $^O eq "VMS";
 335
 336     my (%done, %found);
 337
 338     File::Find::find({no_chdir=>1,
 339                       wanted => sub {
 340                           if (m!/t\z!) {
 341                               ++$File::Find::prune;
 342                               return;
 343                           }
 344
 345                           # $_ is $File::Find::name when using no_chdir
 346                           return unless m!\.p(?:m|od)\z! && -f $_;
 347                           return if m!lib/Net/FTP/.+\.pm\z!; # Hi, Graham! :-)
 348                           # Skip .pm files that have corresponding .pod files
 349                           return if s!\.pm\z!.pod! && -e $_;
 350                           s!\.pod\z!!;
 351                           s!\Alib/!!;
 352                           s!/!::!g;
 353
 354                           my_die("Duplicate files for $_, '$done{$_}' and '$File::Find::name'")
 355                               if exists $done{$_};
 356                           $done{$_} = $File::Find::name;
 357
 358                           return if $do_not_install{$_};
 359                           return if is_duplicate_pod($File::Find::name);
 360                           $found{/\A[a-z]/ ? 'PRAGMA' : 'MODULE'}{$_}
 361                               = $File::Find::name;
 362                       }}, 'lib');
 363     return \%found;
 364 }
 365
 366 my %state = (
 367              # Don't copy these top level READMEs
 368              ignore => {
 369                         micro => 1,
 370                         # vms => 1,
 371                        },
 372             );
 373
 374 {
 375     my (%Lengths, %MD5s);
 376
 377     sub is_duplicate_pod {
 378         my $file = shift;
 379         local $_;
 380
 381         return if !$has_md5;
 382
 383         # Initialise the list of possible source files on the first call.
 384         unless (%Lengths) {
 385             __prime_state() unless $state{master};
 386             foreach (@{$state{master}}) {
 387                 next unless $_->[2]{dual};
 388                 # This is a dual-life perl*.pod file, which will have be copied
 389                 # to lib/ by the build process, and hence also found there.
 390                 # These are the only pod files that might become duplicated.
 391                 ++$Lengths{-s $_->[1]};
 392                 ++$MD5s{md5(slurp_or_die($_->[1]))};
 393             }
 394         }
 395
 396         # We are a file in lib. Are we a duplicate?
 397         # Don't bother calculating the MD5 if there's no interesting file of
 398         # this length.
 399         return $Lengths{-s $file} && $MD5s{md5(slurp_or_die($file))};
 400     }
 401 }
 402
 403 sub __prime_state {
 404     my $source = 'perldelta.pod';
 405     my $filename = "pod/$source";
 406     my $contents = slurp_or_die($filename);
 407     my @want =
 408         $contents =~ /perldelta - what is new for perl v(\d+)\.(\d+)\.(\d+)\r?\n/;
 409     die "Can't extract version from $filename" unless @want;
 410     my $delta_leaf = join '', 'perl', @want, 'delta';
 411     $state{delta_target} = "$delta_leaf.pod";
 412     $state{delta_version} = \@want;
 413
 414     # This way round so that keys can act as a MANIFEST skip list
 415     # Targets will always be in the pod directory. Currently we can only cope
 416     # with sources being in the same directory.
 417     $state{copies}{$state{delta_target}} = $source;
 418
 419     # The default flags if none explicitly set for the current file.
 420     my $current_flags = '';
 421     my (%flag_set, @paths);
 422
 423     my $master = open_or_die('pod/perl.pod');
 424
 425     while (<$master>) {
 426         last if /^=begin buildtoc$/;
 427     }
 428     die "Can't find '=begin buildtoc':" if eof $master;
 429
 430     while (<$master>) {
 431         next if /^$/ or /^#/;
 432         last if /^=end buildtoc/;
 433         my ($command, @args) = split ' ';
 434         if ($command eq 'flag') {
 435             # For the named pods, use these flags, instead of $current_flags
 436             my $flags = shift @args;
 437             my_die("Malformed flag $flags")
 438                 unless $flags =~ /\A=([a-z]*)\z/;
 439             $flag_set{$_} = $1 foreach @args;
 440         } elsif ($command eq 'path') {
 441             # If the pod's name matches the regex, prepend the given path.
 442             my_die("Malformed path for /$args[0]/")
 443                 unless @args == 2;
 444             push @paths, [qr/\A$args[0]\z/, $args[1]];
 445         } elsif ($command eq 'aux') {
 446             # The contents of perltoc.pod's "AUXILIARY DOCUMENTATION" section
 447             $state{aux} = [sort @args];
 448         } else {
 449             my_die("Unknown buildtoc command '$command'");
 450         }
 451     }
 452
 453     foreach (<$master>) {
 454         next if /^$/ or /^#/;
 455         next if /^=head2/;
 456         last if /^=for buildtoc __END__$/;
 457
 458         if (my ($action, $flags) = /^=for buildtoc flag ([-+])([a-z]+)/) {
 459             if ($action eq '+') {
 460                 $current_flags .= $flags;
 461             } else {
 462                 my_die("Attempt to unset [$flags] failed - flags are '$current_flags")
 463                     unless $current_flags =~ s/[\Q$flags\E]//g;
 464             }
 465         } elsif (my ($leafname, $desc) = /^\s+(\S+)\s+(.*)/) {
 466             my $podname = $leafname;
 467             my $filename = "pod/$podname.pod";
 468             foreach (@paths) {
 469                 my ($re, $path) = @$_;
 470                 if ($leafname =~ $re) {
 471                     $podname = $path . $leafname;
 472                     $filename = "$podname.pod";
 473                     last;
 474                 }
 475             }
 476
 477             # Keep this compatible with pre-5.10
 478             my $flags = delete $flag_set{$leafname};
 479             $flags = $current_flags unless defined $flags;
 480
 481             my %flags;
 482             $flags{toc_omit} = 1 if $flags =~ tr/o//d;
 483             $flags{dual} = $podname ne $leafname;
 484
 485             $state{generated}{"$podname.pod"}++ if $flags =~ tr/g//d;
 486
 487             if ($flags =~ tr/r//d) {
 488                 my $readme = $podname;
 489                 $readme =~ s/^perl//;
 490                 $state{readmes}{$readme} = $desc;
 491                 $flags{readme} = 1;
 492             } else {
 493                 $state{pods}{$podname} = $desc;
 494             }
 495             my_die "Unknown flag found in section line: $_" if length $flags;
 496
 497             push @{$state{master}},
 498                 [$leafname, $filename, \%flags];
 499
 500             if ($podname eq 'perldelta') {
 501                 local $" = '.';
 502                 push @{$state{master}},
 503                     [$delta_leaf, "pod/$state{delta_target}"];
 504                 $state{pods}{$delta_leaf} = "Perl changes in version @want";
 505             }
 506
 507         } else {
 508             my_die("Malformed line: $_");
 509         }
 510     }
 511     close $master or my_die("close pod/perl.pod: $!");
 512
 513     my_die("perl.pod sets flags for unknown pods: "
 514            . join ' ', sort keys %flag_set)
 515         if keys %flag_set;
 516 }
 517
 518 =head2 C<get_pod_metadata()>
 519
 520 =over 4
 521
 522 =item * Purpose
 523
 524 =item * Arguments
 525
 526 List of one or more arguments.
 527
 528 =over 4
 529
 530 =item * Boolean true or false
 531
 532 =item * Reference to a subroutine.
 533
 534 =item * Various other arguments.
 535
 536 =back
 537
 538 Example:
 539
 540     $state = get_pod_metadata(
 541         0, sub { warn @_ if @_ }, 'pod/perltoc.pod');
 542
 543     get_pod_metadata(
 544         1, sub { warn @_ if @_ }, values %Build);
 545
 546 =item * Return Value
 547
 548 Hash reference; each element provides either a list or a lookup table for
 549 information about various types of POD files.
 550
 551   'aux'             => [ # utility programs like
 552                             'h2xs' and 'perldoc' ]
 553   'generated'       => { # lookup table for generated POD files
 554                             like 'perlapi.pod' }
 555   'ignore'          => { # lookup table for files to be ignored }
 556   'pods'            => { # lookup table in "name" =>
 557                             "short description" format }
 558   'readmes'         => { # lookup table for OS-specific
 559                             and other READMEs }
 560   'delta_version'   => [ # major version number, minor no.,
 561                             patch no. ]
 562   'delta_target'    => 'perl<Mmmpp>delta.pod',
 563   'master'          => [ # list holding entries for files callable
 564                         by 'perldoc' ]
 565   'copies'          => { # patch version perldelta =>
 566                         minor version perldelta }
 567
 568 =back
 569
 570 =cut
 571
 572 sub get_pod_metadata {
 573     # Do we expect to find generated pods on disk?
 574     my $permit_missing_generated = shift;
 575     # Do they want a consistency report?
 576     my $callback = shift;
 577     local $_;
 578
 579     __prime_state() unless $state{master};
 580     return \%state unless $callback;
 581
 582     my %BuildFiles;
 583
 584     foreach my $path (@_) {
 585         $path =~ m!([^/]+)$!;
 586         ++$BuildFiles{$1};
 587     }
 588
 589     # Sanity cross check
 590
 591     my (%disk_pods, %manipods, %manireadmes);
 592     my (%cpanpods, %cpanpods_leaf);
 593     my (%our_pods);
 594
 595     # There are files that we don't want to list in perl.pod.
 596     # Maybe the various stub manpages should be listed there.
 597     my %ignoredpods = map { ( "$_.pod" => 1 ) } qw( );
 598
 599     # Convert these to a list of filenames.
 600     ++$our_pods{"$_.pod"} foreach keys %{$state{pods}};
 601     foreach (@{$state{master}}) {
 602         ++$our_pods{"$_->[0].pod"}
 603             if $_->[2]{readme};
 604     }
 605
 606     opendir my $dh, 'pod';
 607     while (defined ($_ = readdir $dh)) {
 608         next unless /\.pod\z/;
 609         ++$disk_pods{$_};
 610     }
 611
 612     # Things we copy from won't be in perl.pod
 613     # Things we copy to won't be in MANIFEST
 614
 615     my $mani = open_or_die('MANIFEST');
 616     while (<$mani>) {
 617         chomp;
 618         s/\s+.*$//;
 619         if (m!^pod/([^.]+\.pod)!i) {
 620             ++$manipods{$1};
 621         } elsif (m!^README\.(\S+)!i) {
 622             next if $state{ignore}{$1};
 623             ++$manireadmes{"perl$1.pod"};
 624         } elsif (exists $our_pods{$_}) {
 625             ++$cpanpods{$_};
 626             m!([^/]+)$!;
 627             ++$cpanpods_leaf{$1};
 628             $disk_pods{$_}++
 629                 if -e $_;
 630         }
 631     }
 632     close $mani or my_die "close MANIFEST: $!\n";
 633
 634     # Are we running before known generated files have been generated?
 635     # (eg in a clean checkout)
 636     my %not_yet_there;
 637     if ($permit_missing_generated) {
 638         # If so, don't complain if these files aren't yet in place
 639         %not_yet_there = (%manireadmes, %{$state{generated}}, %{$state{copies}})
 640     }
 641
 642     my @inconsistent;
 643     foreach my $i (sort keys %disk_pods) {
 644         push @inconsistent, "$0: $i exists but is unknown by buildtoc\n"
 645             unless $our_pods{$i} || $ignoredpods{$i};
 646         push @inconsistent, "$0: $i exists but is unknown by MANIFEST\n"
 647             if !$BuildFiles{'MANIFEST'} # Ignore if we're rebuilding MANIFEST
 648                 && !$manipods{$i} && !$manireadmes{$i} && !$state{copies}{$i}
 649                     && !$state{generated}{$i} && !$cpanpods{$i};
 650     }
 651     foreach my $i (sort keys %our_pods) {
 652         push @inconsistent, "$0: $i is known by buildtoc but does not exist\n"
 653             unless $disk_pods{$i} or $BuildFiles{$i} or $not_yet_there{$i};
 654     }
 655     unless ($BuildFiles{'MANIFEST'}) {
 656         # Again, ignore these if we're about to rebuild MANIFEST
 657         foreach my $i (sort keys %manipods) {
 658             push @inconsistent, "$0: $i is known by MANIFEST but does not exist\n"
 659                 unless $disk_pods{$i};
 660             push @inconsistent, "$0: $i is known by MANIFEST but is marked as generated\n"
 661                 if $state{generated}{$i};
 662         }
 663     }
 664     &$callback(@inconsistent);
 665     return \%state;
 666 }
 667
 668 1;
 669
 670 # ex: set ts=8 sts=4 sw=4 et: