8 Porting/pod_lib.pl - functions for building and installing POD
12 require './Porting/pod_lib.pl';
18 This program, when C<require>d into other programs in the Perl 5 core
19 distribution, provides functions useful during building and, secondarily,
22 As of this writing, the functions in this program are used in these other
29 Porting/new-perldelta.pl
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>).
44 Exit from a process with an error code and a message.
48 List of arguments to be passed with the error message. Example:
50 close $fh or my_die("close 'utils.lst': $!");
58 Prints C<ABORTED> to STDERR.
64 # In some situations, eg cross-compiling, we get run with miniperl, so we can't use Digest::MD5
68 $has_md5 = eval { require Digest::MD5; Digest::MD5->import('md5'); 1; };
72 # make it clearer when we haven't run to completion, as we can be quite
73 # noisy when things are working ok
76 print STDERR "$0: ", @_;
77 print STDERR "\n" unless $_[-1] =~ /\n\z/;
78 print STDERR "ABORTED\n";
82 =head2 C<open_or_die()>
88 Opens a file or fails if it cannot.
92 String holding filename to be opened. Example:
94 $fh = open_or_die('utils.lst');
98 Handle to opened file.
105 my $filename = shift;
106 open my $fh, '<', $filename or my_die "Can't open $filename: $!";
110 =head2 C<slurp_or_die()>
116 Read the contents of a file into memory as a single string.
120 String holding name of file to be read into memory.
122 $olddelta = slurp_or_die('pod/perldelta.pod');
126 String holding contents of file.
133 my $filename = shift;
134 my $fh = open_or_die($filename);
137 my $contents = <$fh>;
138 die "Can't read $filename: $!" unless defined $contents and close $fh;
142 =head2 C<write_or_die()>
148 Write out a string to a file.
152 List of two arguments: (i) String holding name of file to be written to; (ii)
153 String holding contents to be written.
155 write_or_die($olddeltaname, $olddelta);
159 Implicitly returns true value upon success.
166 my ($filename, $contents) = @_;
167 open my $fh, '>', $filename or die "Can't open $filename for writing: $!";
169 print $fh $contents or die "Can't write to $filename: $!";
170 close $fh or die "Can't close $filename: $!";
173 =head2 C<verify_contiguous()>
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.
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:
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',
193 (Currently found in C<%Targets> in F<Porting/pod_rules.pl>.)
199 =item * Name of target
201 String holding the key of one element in C<%Targets> in F<Porting/pod_rules.pl>.
203 =item * Contents of file
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.
208 =item * Pattern of interest
210 Compiled regular expression pertinent to a particular makefile constructor.
212 =item * Name to report on error
214 String holding description.
220 The contents of the file, with C<qr/\0+/> substituted for the pattern.
222 =item * Example (drawn from F<Porting/pod_rules.pl> C<do_unix()>):
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');
233 sub verify_contiguous {
234 my ($name, $content, $re, $what) = @_;
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;
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.
259 =item * Description for use in error messages
265 Passed description and file contents, should return updated file contents.
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.
274 If true, generate verbose output.
280 Does not return anything.
287 my ($desc, $filename, $callback, $test, $verbose) = @_;
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/;
293 my $new = $callback->($desc, $orig);
296 printf "%s%s # $filename is up to date\n",
297 ($new eq $orig ? 'ok' : 'not ok'), ($test ? " $test" : '');
299 } elsif ($new eq $orig) {
300 print "Was not modified\n"
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: $!";
311 write_or_die($filename, $new);
312 chmod $mode & 0777, $filename or my_die "can't chmod $mode $filename: $!";
315 =head2 C<pods_to_install()>
321 Create a lookup table holding information about PODs to be installed.
329 Reference to a hash with a structure like this:
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',
339 'Locale::Codes::LangVar' =>
340 'lib/Locale/Codes/LangVar.pod'
343 'fields' => 'lib/fields.pm',
344 'subs' => 'lib/subs.pm',
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.
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
366 File::Find::find({no_chdir=>1,
369 ++$File::Find::prune;
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 $_;
382 my_die("Duplicate files for $_, '$done{$_}' and '$File::Find::name'")
384 $done{$_} = $File::Find::name;
386 return if $do_not_install{$_};
387 return if is_duplicate_pod($File::Find::name);
388 $found{/\A[a-z]/ ? 'PRAGMA' : 'MODULE'}{$_}
395 # Don't copy these top level READMEs
403 my (%Lengths, %MD5s);
405 sub is_duplicate_pod {
411 # Initialise the list of possible source files on the first call.
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]))};
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
427 return $Lengths{-s $file} && $MD5s{md5(slurp_or_die($file))};
432 my $source = 'perldelta.pod';
433 my $filename = "pod/$source";
434 my $contents = slurp_or_die($filename);
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;
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;
447 # The default flags if none explicitly set for the current file.
448 my $current_flags = '';
449 my (%flag_set, @paths);
451 my $master = open_or_die('pod/perl.pod');
454 last if /^=begin buildtoc$/;
456 die "Can't find '=begin buildtoc':" if eof $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]/")
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];
477 my_die("Unknown buildtoc command '$command'");
481 foreach (<$master>) {
482 next if /^$/ or /^#/;
484 last if /^=for buildtoc __END__$/;
486 if (my ($action, $flags) = /^=for buildtoc flag ([-+])([a-z]+)/) {
487 if ($action eq '+') {
488 $current_flags .= $flags;
490 my_die("Attempt to unset [$flags] failed - flags are '$current_flags")
491 unless $current_flags =~ s/[\Q$flags\E]//g;
493 } elsif (my ($leafname, $desc) = /^\s+(\S+)\s+(.*)/) {
494 my $podname = $leafname;
495 my $filename = "pod/$podname.pod";
497 my ($re, $path) = @$_;
498 if ($leafname =~ $re) {
499 $podname = $path . $leafname;
500 $filename = "$podname.pod";
505 # Keep this compatible with pre-5.10
506 my $flags = delete $flag_set{$leafname};
507 $flags = $current_flags unless defined $flags;
510 $flags{toc_omit} = 1 if $flags =~ tr/o//d;
511 $flags{dual} = $podname ne $leafname;
513 $state{generated}{"$podname.pod"}++ if $flags =~ tr/g//d;
515 if ($flags =~ tr/r//d) {
516 my $readme = $podname;
517 $readme =~ s/^perl//;
518 $state{readmes}{$readme} = $desc;
521 $state{pods}{$podname} = $desc;
523 my_die "Unknown flag found in section line: $_" if length $flags;
525 push @{$state{master}},
526 [$leafname, $filename, \%flags];
528 if ($podname eq 'perldelta') {
530 push @{$state{master}},
531 [$delta_leaf, "pod/$state{delta_target}"];
532 $state{pods}{$delta_leaf} = "Perl changes in version @want";
536 my_die("Malformed line: $_");
539 close $master or my_die("close pod/perl.pod: $!");
541 my_die("perl.pod sets flags for unknown pods: "
542 . join ' ', sort keys %flag_set)
546 =head2 C<get_pod_metadata()>
552 Create a data structure holding information about files containing text in POD format.
556 List of one or more arguments.
560 =item * Boolean true or false
562 =item * Reference to a subroutine.
564 =item * Various other arguments.
570 $state = get_pod_metadata(
571 0, sub { warn @_ if @_ }, 'pod/perltoc.pod');
574 1, sub { warn @_ if @_ }, values %Build);
578 Hash reference; each element provides either a list or a lookup table for
579 information about various types of POD files.
581 'aux' => [ # utility programs like
582 'h2xs' and 'perldoc' ]
583 'generated' => { # lookup table for generated POD files
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
590 'delta_version' => [ # major version number, minor no.,
592 'delta_target' => 'perl<Mmmpp>delta.pod',
593 'master' => [ # list holding entries for files callable
595 'copies' => { # patch version perldelta =>
596 minor version perldelta }
600 Instances where this subroutine is used may be found in these files:
603 Porting/new-perldelta.pl
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;
617 __prime_state() unless $state{master};
618 return \%state unless $callback;
622 foreach my $path (@_) {
623 $path =~ m!([^/]+)$!;
629 my (%disk_pods, %manipods, %manireadmes);
630 my (%cpanpods, %cpanpods_leaf);
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( );
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"}
644 opendir my $dh, 'pod';
645 while (defined ($_ = readdir $dh)) {
646 next unless /\.pod\z/;
650 # Things we copy from won't be in perl.pod
651 # Things we copy to won't be in MANIFEST
653 my $mani = open_or_die('MANIFEST');
657 if (m!^pod/([^.]+\.pod)!i) {
659 } elsif (m!^README\.(\S+)!i) {
660 next if $state{ignore}{$1};
661 ++$manireadmes{"perl$1.pod"};
662 } elsif (exists $our_pods{$_}) {
665 ++$cpanpods_leaf{$1};
670 close $mani or my_die "close MANIFEST: $!\n";
672 # Are we running before known generated files have been generated?
673 # (eg in a clean checkout)
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}})
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};
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};
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};
702 &$callback(@inconsistent);
708 # ex: set ts=8 sts=4 sw=4 et: