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<pods_to_install()>
 164
 165 =over 4
 166
 167 =item * Purpose
 168
 169 Create a lookup table holding information about PODs to be installed.
 170
 171 =item * Arguments
 172
 173 None.
 174
 175 =item * Return Value
 176
 177 Reference to a hash with a structure like this:
 178
 179     $found = {
 180       'MODULE' => {
 181         'CPAN::Bundle' => 'lib/CPAN/Bundle.pm',
 182         'Locale::Codes::Script_Retired' =>
 183             'lib/Locale/Codes/Script_Retired.pm',
 184         'Pod::Simple::DumpAsText' =>
 185             'lib/Pod/Simple/DumpAsText.pm',
 186         # ...
 187         'Locale::Codes::LangVar' =>
 188             'lib/Locale/Codes/LangVar.pod'
 189       },
 190       'PRAGMA' => {
 191         'fields' => 'lib/fields.pm',
 192         'subs' => 'lib/subs.pm',
 193         # ...
 194       },
 195
 196 =item * Comment
 197
 198 Broadly speaking, the function assembles a list of all F<.pm> and F<.pod>
 199 files in the distribution and then excludes certain files from installation.
 200
 201 =back
 202
 203 =cut
 204
 205 sub pods_to_install {
 206     # manpages not to be installed
 207     my %do_not_install = map { ($_ => 1) }
 208         qw(Pod::Functions XS::APItest XS::Typemap);
 209
 210     my (%done, %found);
 211
 212     File::Find::find({no_chdir=>1,
 213                       wanted => sub {
 214                           if (m!/t\z!) {
 215                               ++$File::Find::prune;
 216                               return;
 217                           }
 218
 219                           # $_ is $File::Find::name when using no_chdir
 220                           return unless m!\.p(?:m|od)\z! && -f $_;
 221                           return if m!lib/Net/FTP/.+\.pm\z!; # Hi, Graham! :-)
 222                           # Skip .pm files that have corresponding .pod files
 223                           return if s!\.pm\z!.pod! && -e $_;
 224                           s!\.pod\z!!;
 225                           s!\Alib/!!;
 226                           s!/!::!g;
 227
 228                           my_die("Duplicate files for $_, '$done{$_}' and '$File::Find::name'")
 229                               if exists $done{$_};
 230                           $done{$_} = $File::Find::name;
 231
 232                           return if $do_not_install{$_};
 233                           return if is_duplicate_pod($File::Find::name);
 234                           $found{/\A[a-z]/ ? 'PRAGMA' : 'MODULE'}{$_}
 235                               = $File::Find::name;
 236                       }}, 'lib');
 237     return \%found;
 238 }
 239
 240 my %state = (
 241              # Don't copy these top level READMEs
 242              ignore => {
 243                         micro => 1,
 244                         # vms => 1,
 245                        },
 246             );
 247
 248 {
 249     my (%Lengths, %MD5s);
 250
 251     sub is_duplicate_pod {
 252         my $file = shift;
 253         local $_;
 254
 255         # Initialise the list of possible source files on the first call.
 256         unless (%Lengths) {
 257             __prime_state() unless $state{master};
 258             foreach (@{$state{master}}) {
 259                 next unless $_->[2]{dual};
 260                 # This is a dual-life perl*.pod file, which will have be copied
 261                 # to lib/ by the build process, and hence also found there.
 262                 # These are the only pod files that might become duplicated.
 263                 ++$Lengths{-s $_->[1]};
 264                 ++$MD5s{md5(slurp_or_die($_->[1]))};
 265             }
 266         }
 267
 268         # We are a file in lib. Are we a duplicate?
 269         # Don't bother calculating the MD5 if there's no interesting file of
 270         # this length.
 271         return $Lengths{-s $file} && $MD5s{md5(slurp_or_die($file))};
 272     }
 273 }
 274
 275 sub __prime_state {
 276     my $source = 'perldelta.pod';
 277     my $filename = "pod/$source";
 278     my $contents = slurp_or_die($filename);
 279     my @want =
 280         $contents =~ /perldelta - what is new for perl v(5)\.(\d+)\.(\d+)\n/;
 281     die "Can't extract version from $filename" unless @want;
 282     my $delta_leaf = join '', 'perl', @want, 'delta';
 283     $state{delta_target} = "$delta_leaf.pod";
 284     $state{delta_version} = \@want;
 285
 286     # This way round so that keys can act as a MANIFEST skip list
 287     # Targets will always be in the pod directory. Currently we can only cope
 288     # with sources being in the same directory.
 289     $state{copies}{$state{delta_target}} = $source;
 290
 291     # The default flags if none explicitly set for the current file.
 292     my $current_flags = '';
 293     my (%flag_set, @paths);
 294
 295     my $master = open_or_die('pod/perl.pod');
 296
 297     while (<$master>) {
 298         last if /^=begin buildtoc$/;
 299     }
 300     die "Can't find '=begin buildtoc':" if eof $master;
 301
 302     while (<$master>) {
 303         next if /^$/ or /^#/;
 304         last if /^=end buildtoc/;
 305         my ($command, @args) = split ' ';
 306         if ($command eq 'flag') {
 307             # For the named pods, use these flags, instead of $current_flags
 308             my $flags = shift @args;
 309             my_die("Malformed flag $flags")
 310                 unless $flags =~ /\A=([a-z]*)\z/;
 311             $flag_set{$_} = $1 foreach @args;
 312         } elsif ($command eq 'path') {
 313             # If the pod's name matches the regex, prepend the given path.
 314             my_die("Malformed path for /$args[0]/")
 315                 unless @args == 2;
 316             push @paths, [qr/\A$args[0]\z/, $args[1]];
 317         } elsif ($command eq 'aux') {
 318             # The contents of perltoc.pod's "AUXILIARY DOCUMENTATION" section
 319             $state{aux} = [sort @args];
 320         } else {
 321             my_die("Unknown buildtoc command '$command'");
 322         }
 323     }
 324
 325     foreach (<$master>) {
 326         next if /^$/ or /^#/;
 327         next if /^=head2/;
 328         last if /^=for buildtoc __END__$/;
 329
 330         if (my ($action, $flags) = /^=for buildtoc flag ([-+])([a-z]+)/) {
 331             if ($action eq '+') {
 332                 $current_flags .= $flags;
 333             } else {
 334                 my_die("Attempt to unset [$flags] failed - flags are '$current_flags")
 335                     unless $current_flags =~ s/[\Q$flags\E]//g;
 336             }
 337         } elsif (my ($leafname, $desc) = /^\s+(\S+)\s+(.*)/) {
 338             my $podname = $leafname;
 339             my $filename = "pod/$podname.pod";
 340             foreach (@paths) {
 341                 my ($re, $path) = @$_;
 342                 if ($leafname =~ $re) {
 343                     $podname = $path . $leafname;
 344                     $filename = "$podname.pod";
 345                     last;
 346                 }
 347             }
 348
 349             # Keep this compatible with pre-5.10
 350             my $flags = delete $flag_set{$leafname};
 351             $flags = $current_flags unless defined $flags;
 352
 353             my %flags;
 354             $flags{toc_omit} = 1 if $flags =~ tr/o//d;
 355             $flags{dual} = $podname ne $leafname;
 356
 357             $state{generated}{"$podname.pod"}++ if $flags =~ tr/g//d;
 358
 359             if ($flags =~ tr/r//d) {
 360                 my $readme = $podname;
 361                 $readme =~ s/^perl//;
 362                 $state{readmes}{$readme} = $desc;
 363                 $flags{readme} = 1;
 364             } else {
 365                 $state{pods}{$podname} = $desc;
 366             }
 367             my_die "Unknown flag found in section line: $_" if length $flags;
 368
 369             push @{$state{master}},
 370                 [$leafname, $filename, \%flags];
 371
 372             if ($podname eq 'perldelta') {
 373                 local $" = '.';
 374                 push @{$state{master}},
 375                     [$delta_leaf, "pod/$state{delta_target}"];
 376                 $state{pods}{$delta_leaf} = "Perl changes in version @want";
 377             }
 378
 379         } else {
 380             my_die("Malformed line: $_");
 381         }
 382     }
 383     close $master or my_die("close pod/perl.pod: $!");
 384     # This has to be special-cased somewhere. Turns out this is cleanest:
 385     push @{$state{master}}, ['a2p', 'x2p/a2p.pod', {toc_omit => 1}];
 386
 387     my_die("perl.pod sets flags for unknown pods: "
 388            . join ' ', sort keys %flag_set)
 389         if keys %flag_set;
 390 }
 391
 392 =head2 C<get_pod_metadata()>
 393
 394 =over 4
 395
 396 =item * Purpose
 397
 398 =item * Arguments
 399
 400 List of one or more arguments.
 401
 402 =over 4
 403
 404 =item * Boolean true or false
 405
 406 =item * Reference to a subroutine.
 407
 408 =item * Various other arguments.
 409
 410 =back
 411
 412 Example:
 413
 414     $state = get_pod_metadata(
 415         0, sub { warn @_ if @_ }, 'pod/perltoc.pod');
 416
 417     get_pod_metadata(
 418         1, sub { warn @_ if @_ }, values %Build);
 419
 420 =item * Return Value
 421
 422 Hash reference; each element provides either a list or a lookup table for
 423 information about various types of POD files.
 424
 425   'aux'             => [ # utility programs like
 426                             'h2xs' and 'perlbug' ]
 427   'generated'       => { # lookup table for generated POD files
 428                             like 'perlapi.pod' }
 429   'ignore'          => { # lookup table for files to be ignored }
 430   'pods'            => { # lookup table in "name" =>
 431                             "short description" format }
 432   'readmes'         => { # lookup table for OS-specific
 433                             and other READMEs }
 434   'delta_version'   => [ # major version number, minor no.,
 435                             patch no. ]
 436   'delta_target'    => 'perl<Mmmpp>delta.pod',
 437   'master'          => [ # list holding entries for files callable
 438                         by 'perldoc' ]
 439   'copies'          => { # patch version perldelta =>
 440                         minor version perldelta }
 441
 442 =back
 443
 444 =cut
 445
 446 sub get_pod_metadata {
 447     # Do we expect to find generated pods on disk?
 448     my $permit_missing_generated = shift;
 449     # Do they want a consistency report?
 450     my $callback = shift;
 451     local $_;
 452
 453     __prime_state() unless $state{master};
 454     return \%state unless $callback;
 455
 456     my %BuildFiles;
 457
 458     foreach my $path (@_) {
 459         $path =~ m!([^/]+)$!;
 460         ++$BuildFiles{$1};
 461     }
 462
 463     # Sanity cross check
 464
 465     my (%disk_pods, %manipods, %manireadmes);
 466     my (%cpanpods, %cpanpods_leaf);
 467     my (%our_pods);
 468
 469     # There are files that we don't want to list in perl.pod.
 470     # Maybe the various stub manpages should be listed there.
 471     my %ignoredpods = map { ( "$_.pod" => 1 ) } qw( );
 472
 473     # Convert these to a list of filenames.
 474     ++$our_pods{"$_.pod"} foreach keys %{$state{pods}};
 475     foreach (@{$state{master}}) {
 476         ++$our_pods{"$_->[0].pod"}
 477             if $_->[2]{readme};
 478     }
 479
 480     opendir my $dh, 'pod';
 481     while (defined ($_ = readdir $dh)) {
 482         next unless /\.pod\z/;
 483         ++$disk_pods{$_};
 484     }
 485
 486     # Things we copy from won't be in perl.pod
 487     # Things we copy to won't be in MANIFEST
 488
 489     my $mani = open_or_die('MANIFEST');
 490     while (<$mani>) {
 491         chomp;
 492         s/\s+.*$//;
 493         if (m!^pod/([^.]+\.pod)!i) {
 494             ++$manipods{$1};
 495         } elsif (m!^README\.(\S+)!i) {
 496             next if $state{ignore}{$1};
 497             ++$manireadmes{"perl$1.pod"};
 498         } elsif (exists $our_pods{$_}) {
 499             ++$cpanpods{$_};
 500             m!([^/]+)$!;
 501             ++$cpanpods_leaf{$1};
 502             $disk_pods{$_}++
 503                 if -e $_;
 504         }
 505     }
 506     close $mani or my_die "close MANIFEST: $!\n";
 507
 508     # Are we running before known generated files have been generated?
 509     # (eg in a clean checkout)
 510     my %not_yet_there;
 511     if ($permit_missing_generated) {
 512         # If so, don't complain if these files aren't yet in place
 513         %not_yet_there = (%manireadmes, %{$state{generated}}, %{$state{copies}})
 514     }
 515
 516     my @inconsistent;
 517     foreach my $i (sort keys %disk_pods) {
 518         push @inconsistent, "$0: $i exists but is unknown by buildtoc\n"
 519             unless $our_pods{$i} || $ignoredpods{$i};
 520         push @inconsistent, "$0: $i exists but is unknown by MANIFEST\n"
 521             if !$BuildFiles{'MANIFEST'} # Ignore if we're rebuilding MANIFEST
 522                 && !$manipods{$i} && !$manireadmes{$i} && !$state{copies}{$i}
 523                     && !$state{generated}{$i} && !$cpanpods{$i};
 524     }
 525     foreach my $i (sort keys %our_pods) {
 526         push @inconsistent, "$0: $i is known by buildtoc but does not exist\n"
 527             unless $disk_pods{$i} or $BuildFiles{$i} or $not_yet_there{$i};
 528     }
 529     unless ($BuildFiles{'MANIFEST'}) {
 530         # Again, ignore these if we're about to rebuild MANIFEST
 531         foreach my $i (sort keys %manipods) {
 532             push @inconsistent, "$0: $i is known by MANIFEST but does not exist\n"
 533                 unless $disk_pods{$i};
 534             push @inconsistent, "$0: $i is known by MANIFEST but is marked as generated\n"
 535                 if $state{generated}{$i};
 536         }
 537     }
 538     &$callback(@inconsistent);
 539     return \%state;
 540 }
 541
 542 1;
 543
 544 # Local variables:
 545 # cperl-indent-level: 4
 546 # indent-tabs-mode: nil
 547 # End:
 548 #
 549 # ex: set ts=8 sts=4 sw=4 et: