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
 334     my (%done, %found);
 335
 336     File::Find::find({no_chdir=>1,
 337                       wanted => sub {
 338                           if (m!/t\z!) {
 339                               ++$File::Find::prune;
 340                               return;
 341                           }
 342
 343                           # $_ is $File::Find::name when using no_chdir
 344                           return unless m!\.p(?:m|od)\z! && -f $_;
 345                           return if m!lib/Net/FTP/.+\.pm\z!; # Hi, Graham! :-)
 346                           # Skip .pm files that have corresponding .pod files
 347                           return if s!\.pm\z!.pod! && -e $_;
 348                           s!\.pod\z!!;
 349                           s!\Alib/!!;
 350                           s!/!::!g;
 351
 352                           my_die("Duplicate files for $_, '$done{$_}' and '$File::Find::name'")
 353                               if exists $done{$_};
 354                           $done{$_} = $File::Find::name;
 355
 356                           return if $do_not_install{$_};
 357                           return if is_duplicate_pod($File::Find::name);
 358                           $found{/\A[a-z]/ ? 'PRAGMA' : 'MODULE'}{$_}
 359                               = $File::Find::name;
 360                       }}, 'lib');
 361     return \%found;
 362 }
 363
 364 my %state = (
 365              # Don't copy these top level READMEs
 366              ignore => {
 367                         micro => 1,
 368                         # vms => 1,
 369                        },
 370             );
 371
 372 {
 373     my (%Lengths, %MD5s);
 374
 375     sub is_duplicate_pod {
 376         my $file = shift;
 377         local $_;
 378
 379         return if !$has_md5;
 380
 381         # Initialise the list of possible source files on the first call.
 382         unless (%Lengths) {
 383             __prime_state() unless $state{master};
 384             foreach (@{$state{master}}) {
 385                 next unless $_->[2]{dual};
 386                 # This is a dual-life perl*.pod file, which will have be copied
 387                 # to lib/ by the build process, and hence also found there.
 388                 # These are the only pod files that might become duplicated.
 389                 ++$Lengths{-s $_->[1]};
 390                 ++$MD5s{md5(slurp_or_die($_->[1]))};
 391             }
 392         }
 393
 394         # We are a file in lib. Are we a duplicate?
 395         # Don't bother calculating the MD5 if there's no interesting file of
 396         # this length.
 397         return $Lengths{-s $file} && $MD5s{md5(slurp_or_die($file))};
 398     }
 399 }
 400
 401 sub __prime_state {
 402     my $source = 'perldelta.pod';
 403     my $filename = "pod/$source";
 404     my $contents = slurp_or_die($filename);
 405     my @want =
 406         $contents =~ /perldelta - what is new for perl v(5)\.(\d+)\.(\d+)\r?\n/;
 407     die "Can't extract version from $filename" unless @want;
 408     my $delta_leaf = join '', 'perl', @want, 'delta';
 409     $state{delta_target} = "$delta_leaf.pod";
 410     $state{delta_version} = \@want;
 411
 412     # This way round so that keys can act as a MANIFEST skip list
 413     # Targets will always be in the pod directory. Currently we can only cope
 414     # with sources being in the same directory.
 415     $state{copies}{$state{delta_target}} = $source;
 416
 417     # The default flags if none explicitly set for the current file.
 418     my $current_flags = '';
 419     my (%flag_set, @paths);
 420
 421     my $master = open_or_die('pod/perl.pod');
 422
 423     while (<$master>) {
 424         last if /^=begin buildtoc$/;
 425     }
 426     die "Can't find '=begin buildtoc':" if eof $master;
 427
 428     while (<$master>) {
 429         next if /^$/ or /^#/;
 430         last if /^=end buildtoc/;
 431         my ($command, @args) = split ' ';
 432         if ($command eq 'flag') {
 433             # For the named pods, use these flags, instead of $current_flags
 434             my $flags = shift @args;
 435             my_die("Malformed flag $flags")
 436                 unless $flags =~ /\A=([a-z]*)\z/;
 437             $flag_set{$_} = $1 foreach @args;
 438         } elsif ($command eq 'path') {
 439             # If the pod's name matches the regex, prepend the given path.
 440             my_die("Malformed path for /$args[0]/")
 441                 unless @args == 2;
 442             push @paths, [qr/\A$args[0]\z/, $args[1]];
 443         } elsif ($command eq 'aux') {
 444             # The contents of perltoc.pod's "AUXILIARY DOCUMENTATION" section
 445             $state{aux} = [sort @args];
 446         } else {
 447             my_die("Unknown buildtoc command '$command'");
 448         }
 449     }
 450
 451     foreach (<$master>) {
 452         next if /^$/ or /^#/;
 453         next if /^=head2/;
 454         last if /^=for buildtoc __END__$/;
 455
 456         if (my ($action, $flags) = /^=for buildtoc flag ([-+])([a-z]+)/) {
 457             if ($action eq '+') {
 458                 $current_flags .= $flags;
 459             } else {
 460                 my_die("Attempt to unset [$flags] failed - flags are '$current_flags")
 461                     unless $current_flags =~ s/[\Q$flags\E]//g;
 462             }
 463         } elsif (my ($leafname, $desc) = /^\s+(\S+)\s+(.*)/) {
 464             my $podname = $leafname;
 465             my $filename = "pod/$podname.pod";
 466             foreach (@paths) {
 467                 my ($re, $path) = @$_;
 468                 if ($leafname =~ $re) {
 469                     $podname = $path . $leafname;
 470                     $filename = "$podname.pod";
 471                     last;
 472                 }
 473             }
 474
 475             # Keep this compatible with pre-5.10
 476             my $flags = delete $flag_set{$leafname};
 477             $flags = $current_flags unless defined $flags;
 478
 479             my %flags;
 480             $flags{toc_omit} = 1 if $flags =~ tr/o//d;
 481             $flags{dual} = $podname ne $leafname;
 482
 483             $state{generated}{"$podname.pod"}++ if $flags =~ tr/g//d;
 484
 485             if ($flags =~ tr/r//d) {
 486                 my $readme = $podname;
 487                 $readme =~ s/^perl//;
 488                 $state{readmes}{$readme} = $desc;
 489                 $flags{readme} = 1;
 490             } else {
 491                 $state{pods}{$podname} = $desc;
 492             }
 493             my_die "Unknown flag found in section line: $_" if length $flags;
 494
 495             push @{$state{master}},
 496                 [$leafname, $filename, \%flags];
 497
 498             if ($podname eq 'perldelta') {
 499                 local $" = '.';
 500                 push @{$state{master}},
 501                     [$delta_leaf, "pod/$state{delta_target}"];
 502                 $state{pods}{$delta_leaf} = "Perl changes in version @want";
 503             }
 504
 505         } else {
 506             my_die("Malformed line: $_");
 507         }
 508     }
 509     close $master or my_die("close pod/perl.pod: $!");
 510
 511     my_die("perl.pod sets flags for unknown pods: "
 512            . join ' ', sort keys %flag_set)
 513         if keys %flag_set;
 514 }
 515
 516 =head2 C<get_pod_metadata()>
 517
 518 =over 4
 519
 520 =item * Purpose
 521
 522 =item * Arguments
 523
 524 List of one or more arguments.
 525
 526 =over 4
 527
 528 =item * Boolean true or false
 529
 530 =item * Reference to a subroutine.
 531
 532 =item * Various other arguments.
 533
 534 =back
 535
 536 Example:
 537
 538     $state = get_pod_metadata(
 539         0, sub { warn @_ if @_ }, 'pod/perltoc.pod');
 540
 541     get_pod_metadata(
 542         1, sub { warn @_ if @_ }, values %Build);
 543
 544 =item * Return Value
 545
 546 Hash reference; each element provides either a list or a lookup table for
 547 information about various types of POD files.
 548
 549   'aux'             => [ # utility programs like
 550                             'h2xs' and 'perlbug' ]
 551   'generated'       => { # lookup table for generated POD files
 552                             like 'perlapi.pod' }
 553   'ignore'          => { # lookup table for files to be ignored }
 554   'pods'            => { # lookup table in "name" =>
 555                             "short description" format }
 556   'readmes'         => { # lookup table for OS-specific
 557                             and other READMEs }
 558   'delta_version'   => [ # major version number, minor no.,
 559                             patch no. ]
 560   'delta_target'    => 'perl<Mmmpp>delta.pod',
 561   'master'          => [ # list holding entries for files callable
 562                         by 'perldoc' ]
 563   'copies'          => { # patch version perldelta =>
 564                         minor version perldelta }
 565
 566 =back
 567
 568 =cut
 569
 570 sub get_pod_metadata {
 571     # Do we expect to find generated pods on disk?
 572     my $permit_missing_generated = shift;
 573     # Do they want a consistency report?
 574     my $callback = shift;
 575     local $_;
 576
 577     __prime_state() unless $state{master};
 578     return \%state unless $callback;
 579
 580     my %BuildFiles;
 581
 582     foreach my $path (@_) {
 583         $path =~ m!([^/]+)$!;
 584         ++$BuildFiles{$1};
 585     }
 586
 587     # Sanity cross check
 588
 589     my (%disk_pods, %manipods, %manireadmes);
 590     my (%cpanpods, %cpanpods_leaf);
 591     my (%our_pods);
 592
 593     # There are files that we don't want to list in perl.pod.
 594     # Maybe the various stub manpages should be listed there.
 595     my %ignoredpods = map { ( "$_.pod" => 1 ) } qw( );
 596
 597     # Convert these to a list of filenames.
 598     ++$our_pods{"$_.pod"} foreach keys %{$state{pods}};
 599     foreach (@{$state{master}}) {
 600         ++$our_pods{"$_->[0].pod"}
 601             if $_->[2]{readme};
 602     }
 603
 604     opendir my $dh, 'pod';
 605     while (defined ($_ = readdir $dh)) {
 606         next unless /\.pod\z/;
 607         ++$disk_pods{$_};
 608     }
 609
 610     # Things we copy from won't be in perl.pod
 611     # Things we copy to won't be in MANIFEST
 612
 613     my $mani = open_or_die('MANIFEST');
 614     while (<$mani>) {
 615         chomp;
 616         s/\s+.*$//;
 617         if (m!^pod/([^.]+\.pod)!i) {
 618             ++$manipods{$1};
 619         } elsif (m!^README\.(\S+)!i) {
 620             next if $state{ignore}{$1};
 621             ++$manireadmes{"perl$1.pod"};
 622         } elsif (exists $our_pods{$_}) {
 623             ++$cpanpods{$_};
 624             m!([^/]+)$!;
 625             ++$cpanpods_leaf{$1};
 626             $disk_pods{$_}++
 627                 if -e $_;
 628         }
 629     }
 630     close $mani or my_die "close MANIFEST: $!\n";
 631
 632     # Are we running before known generated files have been generated?
 633     # (eg in a clean checkout)
 634     my %not_yet_there;
 635     if ($permit_missing_generated) {
 636         # If so, don't complain if these files aren't yet in place
 637         %not_yet_there = (%manireadmes, %{$state{generated}}, %{$state{copies}})
 638     }
 639
 640     my @inconsistent;
 641     foreach my $i (sort keys %disk_pods) {
 642         push @inconsistent, "$0: $i exists but is unknown by buildtoc\n"
 643             unless $our_pods{$i} || $ignoredpods{$i};
 644         push @inconsistent, "$0: $i exists but is unknown by MANIFEST\n"
 645             if !$BuildFiles{'MANIFEST'} # Ignore if we're rebuilding MANIFEST
 646                 && !$manipods{$i} && !$manireadmes{$i} && !$state{copies}{$i}
 647                     && !$state{generated}{$i} && !$cpanpods{$i};
 648     }
 649     foreach my $i (sort keys %our_pods) {
 650         push @inconsistent, "$0: $i is known by buildtoc but does not exist\n"
 651             unless $disk_pods{$i} or $BuildFiles{$i} or $not_yet_there{$i};
 652     }
 653     unless ($BuildFiles{'MANIFEST'}) {
 654         # Again, ignore these if we're about to rebuild MANIFEST
 655         foreach my $i (sort keys %manipods) {
 656             push @inconsistent, "$0: $i is known by MANIFEST but does not exist\n"
 657                 unless $disk_pods{$i};
 658             push @inconsistent, "$0: $i is known by MANIFEST but is marked as generated\n"
 659                 if $state{generated}{$i};
 660         }
 661     }
 662     &$callback(@inconsistent);
 663     return \%state;
 664 }
 665
 666 1;
 667
 668 # ex: set ts=8 sts=4 sw=4 et: