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 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
189 =item * Contents of file
191 =item * Pattern of interest
193 =item * Name to report on error
199 The contents of the file, with C<qr/\0+/> substituted for the pattern.
205 sub verify_contiguous {
206 my ($name, $content, $re, $what) = @_;
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;
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.
231 =item * Description for use in error messages
237 Passed description and file contents, should return updated file contents.
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.
246 If true, generate verbose output.
252 Does not return anything.
259 my ($desc, $filename, $callback, $test, $verbose) = @_;
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/;
265 my $new = $callback->($desc, $orig);
268 printf "%s%s # $filename is up to date\n",
269 ($new eq $orig ? 'ok' : 'not ok'), ($test ? " $test" : '');
271 } elsif ($new eq $orig) {
272 print "Was not modified\n"
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: $!";
283 write_or_die($filename, $new);
284 chmod $mode & 0777, $filename or my_die "can't chmod $mode $filename: $!";
287 =head2 C<pods_to_install()>
293 Create a lookup table holding information about PODs to be installed.
301 Reference to a hash with a structure like this:
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',
311 'Locale::Codes::LangVar' =>
312 'lib/Locale/Codes/LangVar.pod'
315 'fields' => 'lib/fields.pm',
316 'subs' => 'lib/subs.pm',
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.
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 $do_not_install{"ExtUtils::XSSymSet"} = 1
338 File::Find::find({no_chdir=>1,
341 ++$File::Find::prune;
345 # $_ is $File::Find::name when using no_chdir
346 return unless m!\.p(?:m|od)\z! && -f $_;
347 return if m!lib/Net/FTP/.+\.pm\z!; # Hi, Graham! :-)
348 # Skip .pm files that have corresponding .pod files
349 return if s!\.pm\z!.pod! && -e $_;
354 my_die("Duplicate files for $_, '$done{$_}' and '$File::Find::name'")
356 $done{$_} = $File::Find::name;
358 return if $do_not_install{$_};
359 return if is_duplicate_pod($File::Find::name);
360 $found{/\A[a-z]/ ? 'PRAGMA' : 'MODULE'}{$_}
367 # Don't copy these top level READMEs
375 my (%Lengths, %MD5s);
377 sub is_duplicate_pod {
383 # Initialise the list of possible source files on the first call.
385 __prime_state() unless $state{master};
386 foreach (@{$state{master}}) {
387 next unless $_->[2]{dual};
388 # This is a dual-life perl*.pod file, which will have be copied
389 # to lib/ by the build process, and hence also found there.
390 # These are the only pod files that might become duplicated.
391 ++$Lengths{-s $_->[1]};
392 ++$MD5s{md5(slurp_or_die($_->[1]))};
396 # We are a file in lib. Are we a duplicate?
397 # Don't bother calculating the MD5 if there's no interesting file of
399 return $Lengths{-s $file} && $MD5s{md5(slurp_or_die($file))};
404 my $source = 'perldelta.pod';
405 my $filename = "pod/$source";
406 my $contents = slurp_or_die($filename);
408 $contents =~ /perldelta - what is new for perl v(\d+)\.(\d+)\.(\d+)\r?\n/;
409 die "Can't extract version from $filename" unless @want;
410 my $delta_leaf = join '', 'perl', @want, 'delta';
411 $state{delta_target} = "$delta_leaf.pod";
412 $state{delta_version} = \@want;
414 # This way round so that keys can act as a MANIFEST skip list
415 # Targets will always be in the pod directory. Currently we can only cope
416 # with sources being in the same directory.
417 $state{copies}{$state{delta_target}} = $source;
419 # The default flags if none explicitly set for the current file.
420 my $current_flags = '';
421 my (%flag_set, @paths);
423 my $master = open_or_die('pod/perl.pod');
426 last if /^=begin buildtoc$/;
428 die "Can't find '=begin buildtoc':" if eof $master;
431 next if /^$/ or /^#/;
432 last if /^=end buildtoc/;
433 my ($command, @args) = split ' ';
434 if ($command eq 'flag') {
435 # For the named pods, use these flags, instead of $current_flags
436 my $flags = shift @args;
437 my_die("Malformed flag $flags")
438 unless $flags =~ /\A=([a-z]*)\z/;
439 $flag_set{$_} = $1 foreach @args;
440 } elsif ($command eq 'path') {
441 # If the pod's name matches the regex, prepend the given path.
442 my_die("Malformed path for /$args[0]/")
444 push @paths, [qr/\A$args[0]\z/, $args[1]];
445 } elsif ($command eq 'aux') {
446 # The contents of perltoc.pod's "AUXILIARY DOCUMENTATION" section
447 $state{aux} = [sort @args];
449 my_die("Unknown buildtoc command '$command'");
453 foreach (<$master>) {
454 next if /^$/ or /^#/;
456 last if /^=for buildtoc __END__$/;
458 if (my ($action, $flags) = /^=for buildtoc flag ([-+])([a-z]+)/) {
459 if ($action eq '+') {
460 $current_flags .= $flags;
462 my_die("Attempt to unset [$flags] failed - flags are '$current_flags")
463 unless $current_flags =~ s/[\Q$flags\E]//g;
465 } elsif (my ($leafname, $desc) = /^\s+(\S+)\s+(.*)/) {
466 my $podname = $leafname;
467 my $filename = "pod/$podname.pod";
469 my ($re, $path) = @$_;
470 if ($leafname =~ $re) {
471 $podname = $path . $leafname;
472 $filename = "$podname.pod";
477 # Keep this compatible with pre-5.10
478 my $flags = delete $flag_set{$leafname};
479 $flags = $current_flags unless defined $flags;
482 $flags{toc_omit} = 1 if $flags =~ tr/o//d;
483 $flags{dual} = $podname ne $leafname;
485 $state{generated}{"$podname.pod"}++ if $flags =~ tr/g//d;
487 if ($flags =~ tr/r//d) {
488 my $readme = $podname;
489 $readme =~ s/^perl//;
490 $state{readmes}{$readme} = $desc;
493 $state{pods}{$podname} = $desc;
495 my_die "Unknown flag found in section line: $_" if length $flags;
497 push @{$state{master}},
498 [$leafname, $filename, \%flags];
500 if ($podname eq 'perldelta') {
502 push @{$state{master}},
503 [$delta_leaf, "pod/$state{delta_target}"];
504 $state{pods}{$delta_leaf} = "Perl changes in version @want";
508 my_die("Malformed line: $_");
511 close $master or my_die("close pod/perl.pod: $!");
513 my_die("perl.pod sets flags for unknown pods: "
514 . join ' ', sort keys %flag_set)
518 =head2 C<get_pod_metadata()>
526 List of one or more arguments.
530 =item * Boolean true or false
532 =item * Reference to a subroutine.
534 =item * Various other arguments.
540 $state = get_pod_metadata(
541 0, sub { warn @_ if @_ }, 'pod/perltoc.pod');
544 1, sub { warn @_ if @_ }, values %Build);
548 Hash reference; each element provides either a list or a lookup table for
549 information about various types of POD files.
551 'aux' => [ # utility programs like
552 'h2xs' and 'perldoc' ]
553 'generated' => { # lookup table for generated POD files
555 'ignore' => { # lookup table for files to be ignored }
556 'pods' => { # lookup table in "name" =>
557 "short description" format }
558 'readmes' => { # lookup table for OS-specific
560 'delta_version' => [ # major version number, minor no.,
562 'delta_target' => 'perl<Mmmpp>delta.pod',
563 'master' => [ # list holding entries for files callable
565 'copies' => { # patch version perldelta =>
566 minor version perldelta }
572 sub get_pod_metadata {
573 # Do we expect to find generated pods on disk?
574 my $permit_missing_generated = shift;
575 # Do they want a consistency report?
576 my $callback = shift;
579 __prime_state() unless $state{master};
580 return \%state unless $callback;
584 foreach my $path (@_) {
585 $path =~ m!([^/]+)$!;
591 my (%disk_pods, %manipods, %manireadmes);
592 my (%cpanpods, %cpanpods_leaf);
595 # There are files that we don't want to list in perl.pod.
596 # Maybe the various stub manpages should be listed there.
597 my %ignoredpods = map { ( "$_.pod" => 1 ) } qw( );
599 # Convert these to a list of filenames.
600 ++$our_pods{"$_.pod"} foreach keys %{$state{pods}};
601 foreach (@{$state{master}}) {
602 ++$our_pods{"$_->[0].pod"}
606 opendir my $dh, 'pod';
607 while (defined ($_ = readdir $dh)) {
608 next unless /\.pod\z/;
612 # Things we copy from won't be in perl.pod
613 # Things we copy to won't be in MANIFEST
615 my $mani = open_or_die('MANIFEST');
619 if (m!^pod/([^.]+\.pod)!i) {
621 } elsif (m!^README\.(\S+)!i) {
622 next if $state{ignore}{$1};
623 ++$manireadmes{"perl$1.pod"};
624 } elsif (exists $our_pods{$_}) {
627 ++$cpanpods_leaf{$1};
632 close $mani or my_die "close MANIFEST: $!\n";
634 # Are we running before known generated files have been generated?
635 # (eg in a clean checkout)
637 if ($permit_missing_generated) {
638 # If so, don't complain if these files aren't yet in place
639 %not_yet_there = (%manireadmes, %{$state{generated}}, %{$state{copies}})
643 foreach my $i (sort keys %disk_pods) {
644 push @inconsistent, "$0: $i exists but is unknown by buildtoc\n"
645 unless $our_pods{$i} || $ignoredpods{$i};
646 push @inconsistent, "$0: $i exists but is unknown by MANIFEST\n"
647 if !$BuildFiles{'MANIFEST'} # Ignore if we're rebuilding MANIFEST
648 && !$manipods{$i} && !$manireadmes{$i} && !$state{copies}{$i}
649 && !$state{generated}{$i} && !$cpanpods{$i};
651 foreach my $i (sort keys %our_pods) {
652 push @inconsistent, "$0: $i is known by buildtoc but does not exist\n"
653 unless $disk_pods{$i} or $BuildFiles{$i} or $not_yet_there{$i};
655 unless ($BuildFiles{'MANIFEST'}) {
656 # Again, ignore these if we're about to rebuild MANIFEST
657 foreach my $i (sort keys %manipods) {
658 push @inconsistent, "$0: $i is known by MANIFEST but does not exist\n"
659 unless $disk_pods{$i};
660 push @inconsistent, "$0: $i is known by MANIFEST but is marked as generated\n"
661 if $state{generated}{$i};
664 &$callback(@inconsistent);
670 # ex: set ts=8 sts=4 sw=4 et: