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 makefile or makefile constructor contains exactly one contiguous
 180 run of lines which matches a given pattern. C<croak()>s if the pattern is not
 181 found, or found in more than one place.
 182
 183 By "makefile or makefile constructor" we mean a file which is one of the
 184 right-hand values in this list of key-value pairs:
 185
 186             manifest => 'MANIFEST',
 187             vms => 'vms/descrip_mms.template',
 188             nmake => 'win32/Makefile',
 189             gmake => 'win32/GNUmakefile',
 190             podmak => 'win32/pod.mak',
 191             unix => 'Makefile.SH',
 192
 193 (Currently found in C<%Targets> in F<Porting/pod_rules.pl>.)
 194
 195 =item * Arguments
 196
 197 =over 4
 198
 199 =item * Name of target
 200
 201 String holding the key of one element in C<%Targets> in F<Porting/pod_rules.pl>.
 202
 203 =item * Contents of file
 204
 205 String holding slurped contents of the file named in the value of the element
 206 in C<%Targets> in F<Porting/pod_rules.pl> named in the first argument.
 207
 208 =item * Pattern of interest
 209
 210 Compiled regular expression pertinent to a particular makefile constructor.
 211
 212 =item * Name to report on error
 213
 214 String holding description.
 215
 216 =back
 217
 218 =item * Return Value
 219
 220 The contents of the file, with C<qr/\0+/> substituted for the pattern.
 221
 222 =item * Example (drawn from F<Porting/pod_rules.pl> C<do_unix()>):
 223
 224     my $makefile_SH = slurp_or_die('./Makefile.SH');
 225     my $re = qr/some\s+pattern/;
 226     my $makefile_SH_out =
 227         verify_contiguous('unix', $makefile_SH, $re, 'copy rules');
 228
 229 =back
 230
 231 =cut
 232
 233 sub verify_contiguous {
 234     my ($name, $content, $re, $what) = @_;
 235     require Carp;
 236     $content =~ s/$re/\0/g;
 237     my $sections = () = $content =~ m/\0+/g;
 238     Carp::croak("$0: $name contains no $what") if $sections < 1;
 239     Carp::croak("$0: $name contains discontiguous $what") if $sections > 1;
 240     return $content;
 241 }
 242
 243 =head2 C<process()>
 244
 245 =over 4
 246
 247 =item * Purpose
 248
 249 Read a file from disk, pass the contents to the callback, and either update
 250 the file on disk (if changed) or generate TAP output to confirm that the
 251 version on disk is up to date. C<die>s if the file contains any C<NUL> bytes.
 252 This permits the callback routine to use C<NUL> bytes as placeholders while
 253 manipulating the file's contents.
 254
 255 =item * Arguments
 256
 257 =over 4
 258
 259 =item * Description for use in error messages
 260
 261 =item * Name of file
 262
 263 =item * Callback
 264
 265 Passed description and file contents, should return updated file contents.
 266
 267 =item * Test number
 268
 269 If defined, generate TAP output to C<STDOUT>. If defined and false, generate
 270 an unnumbered test. Otherwise this is the test number in the I<ok> line.
 271
 272 =item * Verbose flag
 273
 274 If true, generate verbose output.
 275
 276 =back
 277
 278 =item * Return Value
 279
 280 Does not return anything.
 281
 282 =back
 283
 284 =cut
 285
 286 sub process {
 287     my ($desc, $filename, $callback, $test, $verbose) = @_;
 288
 289     print "Now processing $filename\n" if $verbose;
 290     my $orig = slurp_or_die($filename);
 291     my_die "$filename contains NUL bytes" if $orig =~ /\0/;
 292
 293     my $new = $callback->($desc, $orig);
 294
 295     if (defined $test) {
 296         printf "%s%s # $filename is up to date\n",
 297             ($new eq $orig ? 'ok' : 'not ok'), ($test ? " $test" : '');
 298         return;
 299     } elsif ($new eq $orig) {
 300         print "Was not modified\n"
 301             if $verbose;
 302         return;
 303     }
 304
 305     my $mode = (stat $filename)[2];
 306     my_die "Can't stat $filename: $!"
 307         unless defined $mode;
 308     rename $filename, "$filename.old"
 309         or my_die "Can't rename $filename to $filename.old: $!";
 310
 311     write_or_die($filename, $new);
 312     chmod $mode & 0777, $filename or my_die "can't chmod $mode $filename: $!";
 313 }
 314
 315 =head2 C<pods_to_install()>
 316
 317 =over 4
 318
 319 =item * Purpose
 320
 321 Create a lookup table holding information about PODs to be installed.
 322
 323 =item * Arguments
 324
 325 None.
 326
 327 =item * Return Value
 328
 329 Reference to a hash with a structure like this:
 330
 331     $found = {
 332       'MODULE' => {
 333         'CPAN::Bundle' => 'lib/CPAN/Bundle.pm',
 334         'Locale::Codes::Script_Retired' =>
 335             'lib/Locale/Codes/Script_Retired.pm',
 336         'Pod::Simple::DumpAsText' =>
 337             'lib/Pod/Simple/DumpAsText.pm',
 338         # ...
 339         'Locale::Codes::LangVar' =>
 340             'lib/Locale/Codes/LangVar.pod'
 341       },
 342       'PRAGMA' => {
 343         'fields' => 'lib/fields.pm',
 344         'subs' => 'lib/subs.pm',
 345         # ...
 346       },
 347
 348 =item * Comment
 349
 350 Broadly speaking, the function assembles a list of all F<.pm> and F<.pod>
 351 files in the distribution and then excludes certain files from installation.
 352
 353 =back
 354
 355 =cut
 356
 357 sub pods_to_install {
 358     # manpages not to be installed
 359     my %do_not_install = map { ($_ => 1) }
 360         qw(Pod::Functions XS::APItest XS::Typemap);
 361     $do_not_install{"ExtUtils::XSSymSet"} = 1
 362         unless $^O eq "VMS";
 363
 364     my (%done, %found);
 365
 366     File::Find::find({no_chdir=>1,
 367                       wanted => sub {
 368                           if (m!/t\z!) {
 369                               ++$File::Find::prune;
 370                               return;
 371                           }
 372
 373                           # $_ is $File::Find::name when using no_chdir
 374                           return unless m!\.p(?:m|od)\z! && -f $_;
 375                           return if m!lib/Net/FTP/.+\.pm\z!; # Hi, Graham! :-)
 376                           # Skip .pm files that have corresponding .pod files
 377                           return if s!\.pm\z!.pod! && -e $_;
 378                           s!\.pod\z!!;
 379                           s!\Alib/!!;
 380                           s!/!::!g;
 381
 382                           my_die("Duplicate files for $_, '$done{$_}' and '$File::Find::name'")
 383                               if exists $done{$_};
 384                           $done{$_} = $File::Find::name;
 385
 386                           return if $do_not_install{$_};
 387                           return if is_duplicate_pod($File::Find::name);
 388                           $found{/\A[a-z]/ ? 'PRAGMA' : 'MODULE'}{$_}
 389                               = $File::Find::name;
 390                       }}, 'lib');
 391     return \%found;
 392 }
 393
 394 my %state = (
 395              # Don't copy these top level READMEs
 396              ignore => {
 397                         micro => 1,
 398                         # vms => 1,
 399                        },
 400             );
 401
 402 {
 403     my (%Lengths, %MD5s);
 404
 405     sub is_duplicate_pod {
 406         my $file = shift;
 407         local $_;
 408
 409         return if !$has_md5;
 410
 411         # Initialise the list of possible source files on the first call.
 412         unless (%Lengths) {
 413             __prime_state() unless $state{master};
 414             foreach (@{$state{master}}) {
 415                 next unless $_->[2]{dual};
 416                 # This is a dual-life perl*.pod file, which will have be copied
 417                 # to lib/ by the build process, and hence also found there.
 418                 # These are the only pod files that might become duplicated.
 419                 ++$Lengths{-s $_->[1]};
 420                 ++$MD5s{md5(slurp_or_die($_->[1]))};
 421             }
 422         }
 423
 424         # We are a file in lib. Are we a duplicate?
 425         # Don't bother calculating the MD5 if there's no interesting file of
 426         # this length.
 427         return $Lengths{-s $file} && $MD5s{md5(slurp_or_die($file))};
 428     }
 429 }
 430
 431 sub __prime_state {
 432     my $source = 'perldelta.pod';
 433     my $filename = "pod/$source";
 434     my $contents = slurp_or_die($filename);
 435     my @want =
 436         $contents =~ /perldelta - what is new for perl v(\d+)\.(\d+)\.(\d+)\r?\n/;
 437     die "Can't extract version from $filename" unless @want;
 438     my $delta_leaf = join '', 'perl', @want, 'delta';
 439     $state{delta_target} = "$delta_leaf.pod";
 440     $state{delta_version} = \@want;
 441
 442     # This way round so that keys can act as a MANIFEST skip list
 443     # Targets will always be in the pod directory. Currently we can only cope
 444     # with sources being in the same directory.
 445     $state{copies}{$state{delta_target}} = $source;
 446
 447     # The default flags if none explicitly set for the current file.
 448     my $current_flags = '';
 449     my (%flag_set, @paths);
 450
 451     my $master = open_or_die('pod/perl.pod');
 452
 453     while (<$master>) {
 454         last if /^=begin buildtoc$/;
 455     }
 456     die "Can't find '=begin buildtoc':" if eof $master;
 457
 458     while (<$master>) {
 459         next if /^$/ or /^#/;
 460         last if /^=end buildtoc/;
 461         my ($command, @args) = split ' ';
 462         if ($command eq 'flag') {
 463             # For the named pods, use these flags, instead of $current_flags
 464             my $flags = shift @args;
 465             my_die("Malformed flag $flags")
 466                 unless $flags =~ /\A=([a-z]*)\z/;
 467             $flag_set{$_} = $1 foreach @args;
 468         } elsif ($command eq 'path') {
 469             # If the pod's name matches the regex, prepend the given path.
 470             my_die("Malformed path for /$args[0]/")
 471                 unless @args == 2;
 472             push @paths, [qr/\A$args[0]\z/, $args[1]];
 473         } elsif ($command eq 'aux') {
 474             # The contents of perltoc.pod's "AUXILIARY DOCUMENTATION" section
 475             $state{aux} = [sort @args];
 476         } else {
 477             my_die("Unknown buildtoc command '$command'");
 478         }
 479     }
 480
 481     foreach (<$master>) {
 482         next if /^$/ or /^#/;
 483         next if /^=head2/;
 484         last if /^=for buildtoc __END__$/;
 485
 486         if (my ($action, $flags) = /^=for buildtoc flag ([-+])([a-z]+)/) {
 487             if ($action eq '+') {
 488                 $current_flags .= $flags;
 489             } else {
 490                 my_die("Attempt to unset [$flags] failed - flags are '$current_flags")
 491                     unless $current_flags =~ s/[\Q$flags\E]//g;
 492             }
 493         } elsif (my ($leafname, $desc) = /^\s+(\S+)\s+(.*)/) {
 494             my $podname = $leafname;
 495             my $filename = "pod/$podname.pod";
 496             foreach (@paths) {
 497                 my ($re, $path) = @$_;
 498                 if ($leafname =~ $re) {
 499                     $podname = $path . $leafname;
 500                     $filename = "$podname.pod";
 501                     last;
 502                 }
 503             }
 504
 505             # Keep this compatible with pre-5.10
 506             my $flags = delete $flag_set{$leafname};
 507             $flags = $current_flags unless defined $flags;
 508
 509             my %flags;
 510             $flags{toc_omit} = 1 if $flags =~ tr/o//d;
 511             $flags{dual} = $podname ne $leafname;
 512
 513             $state{generated}{"$podname.pod"}++ if $flags =~ tr/g//d;
 514
 515             if ($flags =~ tr/r//d) {
 516                 my $readme = $podname;
 517                 $readme =~ s/^perl//;
 518                 $state{readmes}{$readme} = $desc;
 519                 $flags{readme} = 1;
 520             } else {
 521                 $state{pods}{$podname} = $desc;
 522             }
 523             my_die "Unknown flag found in section line: $_" if length $flags;
 524
 525             push @{$state{master}},
 526                 [$leafname, $filename, \%flags];
 527
 528             if ($podname eq 'perldelta') {
 529                 local $" = '.';
 530                 push @{$state{master}},
 531                     [$delta_leaf, "pod/$state{delta_target}"];
 532                 $state{pods}{$delta_leaf} = "Perl changes in version @want";
 533             }
 534
 535         } else {
 536             my_die("Malformed line: $_");
 537         }
 538     }
 539     close $master or my_die("close pod/perl.pod: $!");
 540
 541     my_die("perl.pod sets flags for unknown pods: "
 542            . join ' ', sort keys %flag_set)
 543         if keys %flag_set;
 544 }
 545
 546 =head2 C<get_pod_metadata()>
 547
 548 =over 4
 549
 550 =item * Purpose
 551
 552 Create a data structure holding information about files containing text in POD format.
 553
 554 =item * Arguments
 555
 556 List of one or more arguments.
 557
 558 =over 4
 559
 560 =item * Boolean true or false
 561
 562 =item * Reference to a subroutine.
 563
 564 =item * Various other arguments.
 565
 566 =back
 567
 568 Example:
 569
 570     $state = get_pod_metadata(
 571         0, sub { warn @_ if @_ }, 'pod/perltoc.pod');
 572
 573     get_pod_metadata(
 574         1, sub { warn @_ if @_ }, values %Build);
 575
 576 =item * Return Value
 577
 578 Hash reference; each element provides either a list or a lookup table for
 579 information about various types of POD files.
 580
 581   'aux'             => [ # utility programs like
 582                             'h2xs' and 'perldoc' ]
 583   'generated'       => { # lookup table for generated POD files
 584                             like 'perlapi.pod' }
 585   'ignore'          => { # lookup table for files to be ignored }
 586   'pods'            => { # lookup table in "name" =>
 587                             "short description" format }
 588   'readmes'         => { # lookup table for OS-specific
 589                             and other READMEs }
 590   'delta_version'   => [ # major version number, minor no.,
 591                             patch no. ]
 592   'delta_target'    => 'perl<Mmmpp>delta.pod',
 593   'master'          => [ # list holding entries for files callable
 594                         by 'perldoc' ]
 595   'copies'          => { # patch version perldelta =>
 596                         minor version perldelta }
 597
 598 =item * Comment
 599
 600 Instances where this subroutine is used may be found in these files:
 601
 602     pod/buildtoc
 603     Porting/new-perldelta.pl
 604     Porting/pod_rules.pl
 605
 606 =back
 607
 608 =cut
 609
 610 sub get_pod_metadata {
 611     # Do we expect to find generated pods on disk?
 612     my $permit_missing_generated = shift;
 613     # Do they want a consistency report?
 614     my $callback = shift;
 615     local $_;
 616
 617     __prime_state() unless $state{master};
 618     return \%state unless $callback;
 619
 620     my %BuildFiles;
 621
 622     foreach my $path (@_) {
 623         $path =~ m!([^/]+)$!;
 624         ++$BuildFiles{$1};
 625     }
 626
 627     # Sanity cross check
 628
 629     my (%disk_pods, %manipods, %manireadmes);
 630     my (%cpanpods, %cpanpods_leaf);
 631     my (%our_pods);
 632
 633     # There are files that we don't want to list in perl.pod.
 634     # Maybe the various stub manpages should be listed there.
 635     my %ignoredpods = map { ( "$_.pod" => 1 ) } qw( );
 636
 637     # Convert these to a list of filenames.
 638     ++$our_pods{"$_.pod"} foreach keys %{$state{pods}};
 639     foreach (@{$state{master}}) {
 640         ++$our_pods{"$_->[0].pod"}
 641             if $_->[2]{readme};
 642     }
 643
 644     opendir my $dh, 'pod';
 645     while (defined ($_ = readdir $dh)) {
 646         next unless /\.pod\z/;
 647         ++$disk_pods{$_};
 648     }
 649
 650     # Things we copy from won't be in perl.pod
 651     # Things we copy to won't be in MANIFEST
 652
 653     my $mani = open_or_die('MANIFEST');
 654     while (<$mani>) {
 655         chomp;
 656         s/\s+.*$//;
 657         if (m!^pod/([^.]+\.pod)!i) {
 658             ++$manipods{$1};
 659         } elsif (m!^README\.(\S+)!i) {
 660             next if $state{ignore}{$1};
 661             ++$manireadmes{"perl$1.pod"};
 662         } elsif (exists $our_pods{$_}) {
 663             ++$cpanpods{$_};
 664             m!([^/]+)$!;
 665             ++$cpanpods_leaf{$1};
 666             $disk_pods{$_}++
 667                 if -e $_;
 668         }
 669     }
 670     close $mani or my_die "close MANIFEST: $!\n";
 671
 672     # Are we running before known generated files have been generated?
 673     # (eg in a clean checkout)
 674     my %not_yet_there;
 675     if ($permit_missing_generated) {
 676         # If so, don't complain if these files aren't yet in place
 677         %not_yet_there = (%manireadmes, %{$state{generated}}, %{$state{copies}})
 678     }
 679
 680     my @inconsistent;
 681     foreach my $i (sort keys %disk_pods) {
 682         push @inconsistent, "$0: $i exists but is unknown by buildtoc\n"
 683             unless $our_pods{$i} || $ignoredpods{$i};
 684         push @inconsistent, "$0: $i exists but is unknown by MANIFEST\n"
 685             if !$BuildFiles{'MANIFEST'} # Ignore if we're rebuilding MANIFEST
 686                 && !$manipods{$i} && !$manireadmes{$i} && !$state{copies}{$i}
 687                     && !$state{generated}{$i} && !$cpanpods{$i};
 688     }
 689     foreach my $i (sort keys %our_pods) {
 690         push @inconsistent, "$0: $i is known by buildtoc but does not exist\n"
 691             unless $disk_pods{$i} or $BuildFiles{$i} or $not_yet_there{$i};
 692     }
 693     unless ($BuildFiles{'MANIFEST'}) {
 694         # Again, ignore these if we're about to rebuild MANIFEST
 695         foreach my $i (sort keys %manipods) {
 696             push @inconsistent, "$0: $i is known by MANIFEST but does not exist\n"
 697                 unless $disk_pods{$i};
 698             push @inconsistent, "$0: $i is known by MANIFEST but is marked as generated\n"
 699                 if $state{generated}{$i};
 700         }
 701     }
 702     &$callback(@inconsistent);
 703     return \%state;
 704 }
 705
 706 1;
 707
 708 # ex: set ts=8 sts=4 sw=4 et: