Porting/pod_lib.pl

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