xref: /openbsd/gnu/usr.bin/perl/Porting/pod_lib.pl (revision 3d61058a)
1#!/usr/bin/perl -w
2
3use strict;
4use File::Find;
5
6=head1 NAME
7
8Porting/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
18This program, when C<require>d into other programs in the Perl 5 core
19distribution, provides functions useful during building and, secondarily,
20testing.
21
22As of this writing, the functions in this program are used in these other
23programs:
24
25    installman
26    installperl
27    pod/buildtoc
28    pod/perl.pod
29    Porting/new-perldelta.pl
30    Porting/pod_rules.pl
31
32Note:  Since these functions are used during the Perl build process, they must
33work with F<miniperl>.  That necessarily implies that these functions must not
34rely 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
44Exit from a process with an error code and a message.
45
46=item * Arguments
47
48List 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
54Exit code C<255>.
55
56=item * Comment
57
58Prints 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
65my $has_md5;
66BEGIN {
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
75sub 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
88Opens a file or fails if it cannot.
89
90=item * Arguments
91
92String holding filename to be opened.  Example:
93
94    $fh = open_or_die('utils.lst');
95
96=item * Return Value
97
98Handle to opened file.
99
100=back
101
102=cut
103
104sub 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
116Read the contents of a file into memory as a single string.
117
118=item * Arguments
119
120String holding name of file to be read into memory.
121
122    $olddelta = slurp_or_die('pod/perldelta.pod');
123
124=item * Return Value
125
126String holding contents of file.
127
128=back
129
130=cut
131
132sub 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
148Write out a string to a file.
149
150=item * Arguments
151
152List of two arguments:  (i) String holding name of file to be written to; (ii)
153String holding contents to be written.
154
155    write_or_die($olddeltaname, $olddelta);
156
157=item * Return Value
158
159Implicitly returns true value upon success.
160
161=back
162
163=cut
164
165sub 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
179Verify that a makefile or makefile constructor contains exactly one contiguous
180run of lines which matches a given pattern. C<croak()>s if the pattern is not
181found, or found in more than one place.
182
183By "makefile or makefile constructor" we mean a file which is one of the
184right-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
201String holding the key of one element in C<%Targets> in F<Porting/pod_rules.pl>.
202
203=item * Contents of file
204
205String holding slurped contents of the file named in the value of the element
206in C<%Targets> in F<Porting/pod_rules.pl> named in the first argument.
207
208=item * Pattern of interest
209
210Compiled regular expression pertinent to a particular makefile constructor.
211
212=item * Name to report on error
213
214String holding description.
215
216=back
217
218=item * Return Value
219
220The 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
233sub 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
249Read a file from disk, pass the contents to the callback, and either update
250the file on disk (if changed) or generate TAP output to confirm that the
251version on disk is up to date. C<die>s if the file contains any C<NUL> bytes.
252This permits the callback routine to use C<NUL> bytes as placeholders while
253manipulating 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
265Passed description and file contents, should return updated file contents.
266
267=item * Test number
268
269If defined, generate TAP output to C<STDOUT>. If defined and false, generate
270an unnumbered test. Otherwise this is the test number in the I<ok> line.
271
272=item * Verbose flag
273
274If true, generate verbose output.
275
276=back
277
278=item * Return Value
279
280Does not return anything.
281
282=back
283
284=cut
285
286sub 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
321Create a lookup table holding information about PODs to be installed.
322
323=item * Arguments
324
325None.
326
327=item * Return Value
328
329Reference 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
350Broadly speaking, the function assembles a list of all F<.pm> and F<.pod>
351files in the distribution and then excludes certain files from installation.
352
353=back
354
355=cut
356
357sub 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
394my %state = (
395             # Don't copy these top level READMEs
396             ignore => {
397                        # vms => 1,
398                       },
399            );
400
401{
402    my (%Lengths, %MD5s);
403
404    sub is_duplicate_pod {
405        my $file = shift;
406        local $_;
407
408        return if !$has_md5;
409
410        # Initialise the list of possible source files on the first call.
411        unless (%Lengths) {
412            __prime_state() unless $state{master};
413            foreach (@{$state{master}}) {
414                next unless $_->[2]{dual};
415                # This is a dual-life perl*.pod file, which will have be copied
416                # to lib/ by the build process, and hence also found there.
417                # These are the only pod files that might become duplicated.
418                ++$Lengths{-s $_->[1]};
419                ++$MD5s{md5(slurp_or_die($_->[1]))};
420            }
421        }
422
423        # We are a file in lib. Are we a duplicate?
424        # Don't bother calculating the MD5 if there's no interesting file of
425        # this length.
426        return $Lengths{-s $file} && $MD5s{md5(slurp_or_die($file))};
427    }
428}
429
430sub __prime_state {
431    my $source = 'perldelta.pod';
432    my $filename = "pod/$source";
433    my $contents = slurp_or_die($filename);
434    my @want =
435        $contents =~ /perldelta - what is new for perl v(\d+)\.(\d+)\.(\d+)\r?\n/;
436    die "Can't extract version from $filename" unless @want;
437    my $delta_leaf = join '', 'perl', @want, 'delta';
438    $state{delta_target} = "$delta_leaf.pod";
439    $state{delta_version} = \@want;
440
441    # This way round so that keys can act as a MANIFEST skip list
442    # Targets will always be in the pod directory. Currently we can only cope
443    # with sources being in the same directory.
444    $state{copies}{$state{delta_target}} = $source;
445
446    # The default flags if none explicitly set for the current file.
447    my $current_flags = '';
448    my (%flag_set, @paths);
449
450    my $master = open_or_die('pod/perl.pod');
451
452    while (<$master>) {
453        last if /^=begin buildtoc$/;
454    }
455    die "Can't find '=begin buildtoc':" if eof $master;
456
457    while (<$master>) {
458        next if /^$/ or /^#/;
459        last if /^=end buildtoc/;
460        my ($command, @args) = split ' ';
461        if ($command eq 'flag') {
462            # For the named pods, use these flags, instead of $current_flags
463            my $flags = shift @args;
464            my_die("Malformed flag $flags")
465                unless $flags =~ /\A=([a-z]*)\z/;
466            $flag_set{$_} = $1 foreach @args;
467        } elsif ($command eq 'path') {
468            # If the pod's name matches the regex, prepend the given path.
469            my_die("Malformed path for /$args[0]/")
470                unless @args == 2;
471            push @paths, [qr/\A$args[0]\z/, $args[1]];
472        } elsif ($command eq 'aux') {
473            # The contents of perltoc.pod's "AUXILIARY DOCUMENTATION" section
474            $state{aux} = [sort @args];
475        } else {
476            my_die("Unknown buildtoc command '$command'");
477        }
478    }
479
480    foreach (<$master>) {
481        next if /^$/ or /^#/;
482        next if /^=head2/;
483        last if /^=for buildtoc __END__$/;
484
485        if (my ($action, $flags) = /^=for buildtoc flag ([-+])([a-z]+)/) {
486            if ($action eq '+') {
487                $current_flags .= $flags;
488            } else {
489                my_die("Attempt to unset [$flags] failed - flags are '$current_flags")
490                    unless $current_flags =~ s/[\Q$flags\E]//g;
491            }
492        } elsif (my ($leafname, $desc) = /^\s+(\S+)\s+(.*)/) {
493            my $podname = $leafname;
494            my $filename = "pod/$podname.pod";
495            foreach (@paths) {
496                my ($re, $path) = @$_;
497                if ($leafname =~ $re) {
498                    $podname = $path . $leafname;
499                    $filename = "$podname.pod";
500                    last;
501                }
502            }
503
504            # Keep this compatible with pre-5.10
505            my $flags = delete $flag_set{$leafname};
506            $flags = $current_flags unless defined $flags;
507
508            my %flags;
509            $flags{toc_omit} = 1 if $flags =~ tr/o//d;
510            $flags{dual} = $podname ne $leafname;
511
512            $state{generated}{"$podname.pod"}++ if $flags =~ tr/g//d;
513
514            if ($flags =~ tr/r//d) {
515                my $readme = $podname;
516                $readme =~ s/^perl//;
517                $state{readmes}{$readme} = $desc;
518                $flags{readme} = 1;
519            } else {
520                $state{pods}{$podname} = $desc;
521            }
522            my_die "Unknown flag found in section line: $_" if length $flags;
523
524            push @{$state{master}},
525                [$leafname, $filename, \%flags];
526
527            if ($podname eq 'perldelta') {
528                local $" = '.';
529                push @{$state{master}},
530                    [$delta_leaf, "pod/$state{delta_target}"];
531                $state{pods}{$delta_leaf} = "Perl changes in version @want";
532            }
533
534        } else {
535            my_die("Malformed line: $_");
536        }
537    }
538    close $master or my_die("close pod/perl.pod: $!");
539
540    my_die("perl.pod sets flags for unknown pods: "
541           . join ' ', sort keys %flag_set)
542        if keys %flag_set;
543}
544
545=head2 C<get_pod_metadata()>
546
547=over 4
548
549=item * Purpose
550
551Create a data structure holding information about files containing text in POD format.
552
553=item * Arguments
554
555List of one or more arguments.
556
557=over 4
558
559=item * Boolean true or false
560
561=item * Reference to a subroutine.
562
563=item * Various other arguments.
564
565=back
566
567Example:
568
569    $state = get_pod_metadata(
570        0, sub { warn @_ if @_ }, 'pod/perltoc.pod');
571
572    get_pod_metadata(
573        1, sub { warn @_ if @_ }, values %Build);
574
575=item * Return Value
576
577Hash reference; each element provides either a list or a lookup table for
578information about various types of POD files.
579
580  'aux'             => [ # utility programs like
581                            'h2xs' and 'perldoc' ]
582  'generated'       => { # lookup table for generated POD files
583                            like 'perlapi.pod' }
584  'ignore'          => { # lookup table for files to be ignored }
585  'pods'            => { # lookup table in "name" =>
586                            "short description" format }
587  'readmes'         => { # lookup table for OS-specific
588                            and other READMEs }
589  'delta_version'   => [ # major version number, minor no.,
590                            patch no. ]
591  'delta_target'    => 'perl<Mmmpp>delta.pod',
592  'master'          => [ # list holding entries for files callable
593                        by 'perldoc' ]
594  'copies'          => { # patch version perldelta =>
595                        minor version perldelta }
596
597=item * Comment
598
599Instances where this subroutine is used may be found in these files:
600
601    pod/buildtoc
602    Porting/new-perldelta.pl
603    Porting/pod_rules.pl
604
605=back
606
607=cut
608
609sub get_pod_metadata {
610    # Do we expect to find generated pods on disk?
611    my $permit_missing_generated = shift;
612    # Do they want a consistency report?
613    my $callback = shift;
614    local $_;
615
616    __prime_state() unless $state{master};
617    return \%state unless $callback;
618
619    my %BuildFiles;
620
621    foreach my $path (@_) {
622        $path =~ m!([^/]+)$!;
623        ++$BuildFiles{$1};
624    }
625
626    # Sanity cross check
627
628    my (%disk_pods, %manipods, %manireadmes);
629    my (%cpanpods, %cpanpods_leaf);
630    my (%our_pods);
631
632    # There are files that we don't want to list in perl.pod.
633    # Maybe the various stub manpages should be listed there.
634    my %ignoredpods = map { ( "$_.pod" => 1 ) } qw( );
635
636    # Convert these to a list of filenames.
637    ++$our_pods{"$_.pod"} foreach keys %{$state{pods}};
638    foreach (@{$state{master}}) {
639        ++$our_pods{"$_->[0].pod"}
640            if $_->[2]{readme};
641    }
642
643    opendir my $dh, 'pod';
644    while (defined ($_ = readdir $dh)) {
645        next unless /\.pod\z/;
646        ++$disk_pods{$_};
647    }
648
649    # Things we copy from won't be in perl.pod
650    # Things we copy to won't be in MANIFEST
651
652    my $mani = open_or_die('MANIFEST');
653    while (<$mani>) {
654        chomp;
655        s/\s+.*$//;
656        if (m!^pod/([^.]+\.pod)!i) {
657            ++$manipods{$1};
658        } elsif (m!^README\.(\S+)!i) {
659            next if $state{ignore}{$1};
660            ++$manireadmes{"perl$1.pod"};
661        } elsif (exists $our_pods{$_}) {
662            ++$cpanpods{$_};
663            m!([^/]+)$!;
664            ++$cpanpods_leaf{$1};
665            $disk_pods{$_}++
666                if -e $_;
667        }
668    }
669    close $mani or my_die "close MANIFEST: $!\n";
670
671    # Are we running before known generated files have been generated?
672    # (eg in a clean checkout)
673    my %not_yet_there;
674    if ($permit_missing_generated) {
675        # If so, don't complain if these files aren't yet in place
676        %not_yet_there = (%manireadmes, %{$state{generated}}, %{$state{copies}})
677    }
678
679    my @inconsistent;
680    foreach my $i (sort keys %disk_pods) {
681        push @inconsistent, "$0: $i exists but is unknown by buildtoc\n"
682            unless $our_pods{$i} || $ignoredpods{$i};
683        push @inconsistent, "$0: $i exists but is unknown by MANIFEST\n"
684            if !$BuildFiles{'MANIFEST'} # Ignore if we're rebuilding MANIFEST
685                && !$manipods{$i} && !$manireadmes{$i} && !$state{copies}{$i}
686                    && !$state{generated}{$i} && !$cpanpods{$i};
687    }
688    foreach my $i (sort keys %our_pods) {
689        push @inconsistent, "$0: $i is known by buildtoc but does not exist\n"
690            unless $disk_pods{$i} or $BuildFiles{$i} or $not_yet_there{$i};
691    }
692    unless ($BuildFiles{'MANIFEST'}) {
693        # Again, ignore these if we're about to rebuild MANIFEST
694        foreach my $i (sort keys %manipods) {
695            push @inconsistent, "$0: $i is known by MANIFEST but does not exist\n"
696                unless $disk_pods{$i};
697            push @inconsistent, "$0: $i is known by MANIFEST but is marked as generated\n"
698                if $state{generated}{$i};
699        }
700    }
701    &$callback(@inconsistent);
702    return \%state;
703}
704
7051;
706
707# ex: set ts=8 sts=4 sw=4 et:
708