Porting/pod_lib.pl

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use Digest::MD5 'md5';
   5 use File::Find;
   6
   7 # make it clearer when we haven't run to completion, as we can be quite
   8 # noisy when things are working ok
   9
  10 sub my_die {
  11     print STDERR "$0: ", @_;
  12     print STDERR "\n" unless $_[-1] =~ /\n\z/;
  13     print STDERR "ABORTED\n";
  14     exit 255;
  15 }
  16
  17 sub open_or_die {
  18     my $filename = shift;
  19     open my $fh, '<', $filename or my_die "Can't open $filename: $!";
  20     return $fh;
  21 }
  22
  23 sub slurp_or_die {
  24     my $filename = shift;
  25     my $fh = open_or_die($filename);
  26     binmode $fh;
  27     local $/;
  28     my $contents = <$fh>;
  29     die "Can't read $filename: $!" unless defined $contents and close $fh;
  30     return $contents;
  31 }
  32
  33 sub write_or_die {
  34     my ($filename, $contents) = @_;
  35     open my $fh, '>', $filename or die "Can't open $filename for writing: $!";
  36     binmode $fh;
  37     print $fh $contents or die "Can't write to $filename: $!";
  38     close $fh or die "Can't close $filename: $!";
  39 }
  40
  41 sub pods_to_install {
  42     # manpages not to be installed
  43     my %do_not_install = map { ($_ => 1) }
  44         qw(Pod::Functions XS::APItest XS::Typemap);
  45
  46     my (%done, %found);
  47
  48     File::Find::find({no_chdir=>1,
  49                       wanted => sub {
  50                           if (m!/t\z!) {
  51                               ++$File::Find::prune;
  52                               return;
  53                           }
  54
  55                           # $_ is $File::Find::name when using no_chdir
  56                           return unless m!\.p(?:m|od)\z! && -f $_;
  57                           return if m!lib/Net/FTP/.+\.pm\z!; # Hi, Graham! :-)
  58                           # Skip .pm files that have corresponding .pod files
  59                           return if s!\.pm\z!.pod! && -e $_;
  60                           s!\.pod\z!!;
  61                           s!\Alib/!!;
  62                           s!/!::!g;
  63
  64                           my_die("Duplicate files for $_, '$done{$_}' and '$File::Find::name'")
  65                               if exists $done{$_};
  66                           $done{$_} = $File::Find::name;
  67
  68                           return if $do_not_install{$_};
  69                           return if is_duplicate_pod($File::Find::name);
  70                           $found{/\A[a-z]/ ? 'PRAGMA' : 'MODULE'}{$_}
  71                               = $File::Find::name;
  72                       }}, 'lib');
  73     return \%found;
  74 }
  75
  76 my %state = (
  77              # Don't copy these top level READMEs
  78              ignore => {
  79                         micro => 1,
  80                         # vms => 1,
  81                        },
  82             );
  83
  84 {
  85     my (%Lengths, %MD5s);
  86
  87     sub is_duplicate_pod {
  88         my $file = shift;
  89         local $_;
  90
  91         # Initialise the list of possible source files on the first call.
  92         unless (%Lengths) {
  93             __prime_state() unless $state{master};
  94             foreach (@{$state{master}}) {
  95                 next unless $_->[2]{dual};
  96                 # This is a dual-life perl*.pod file, which will have be copied
  97                 # to lib/ by the build process, and hence also found there.
  98                 # These are the only pod files that might become duplicated.
  99                 ++$Lengths{-s $_->[1]};
 100                 ++$MD5s{md5(slurp_or_die($_->[1]))};
 101             }
 102         }
 103
 104         # We are a file in lib. Are we a duplicate?
 105         # Don't bother calculating the MD5 if there's no interesting file of
 106         # this length.
 107         return $Lengths{-s $file} && $MD5s{md5(slurp_or_die($file))};
 108     }
 109 }
 110
 111 sub __prime_state {
 112     my $source = 'perldelta.pod';
 113     my $filename = "pod/$source";
 114     my $contents = slurp_or_die($filename);
 115     my @want =
 116         $contents =~ /perldelta - what is new for perl v(5)\.(\d+)\.(\d+)\n/;
 117     die "Can't extract version from $filename" unless @want;
 118     my $delta_leaf = join '', 'perl', @want, 'delta';
 119     $state{delta_target} = "$delta_leaf.pod";
 120     $state{delta_version} = \@want;
 121
 122     # This way round so that keys can act as a MANIFEST skip list
 123     # Targets will always be in the pod directory. Currently we can only cope
 124     # with sources being in the same directory.
 125     $state{copies}{$state{delta_target}} = $source;
 126
 127     # The default flags if none explicitly set for the current file.
 128     my $current_flags = '';
 129     my (%flag_set, @paths);
 130
 131     my $master = open_or_die('pod/perl.pod');
 132
 133     while (<$master>) {
 134         last if /^=begin buildtoc$/;
 135     }
 136     die "Can't find '=begin buildtoc':" if eof $master;
 137
 138     while (<$master>) {
 139         next if /^$/ or /^#/;
 140         last if /^=end buildtoc/;
 141         my ($command, @args) = split ' ';
 142         if ($command eq 'flag') {
 143             # For the named pods, use these flags, instead of $current_flags
 144             my $flags = shift @args;
 145             my_die("Malformed flag $flags")
 146                 unless $flags =~ /\A=([a-z]*)\z/;
 147             $flag_set{$_} = $1 foreach @args;
 148         } elsif ($command eq 'path') {
 149             # If the pod's name matches the regex, prepend the given path.
 150             my_die("Malformed path for /$args[0]/")
 151                 unless @args == 2;
 152             push @paths, [qr/\A$args[0]\z/, $args[1]];
 153         } elsif ($command eq 'aux') {
 154             # The contents of perltoc.pod's "AUXILIARY DOCUMENTATION" section
 155             $state{aux} = [sort @args];
 156         } else {
 157             my_die("Unknown buildtoc command '$command'");
 158         }
 159     }
 160
 161     foreach (<$master>) {
 162         next if /^$/ or /^#/;
 163         next if /^=head2/;
 164         last if /^=for buildtoc __END__$/;
 165
 166         if (my ($action, $flags) = /^=for buildtoc flag ([-+])([a-z]+)/) {
 167             if ($action eq '+') {
 168                 $current_flags .= $flags;
 169             } else {
 170                 my_die("Attempt to unset [$flags] failed - flags are '$current_flags")
 171                     unless $current_flags =~ s/[\Q$flags\E]//g;
 172             }
 173         } elsif (my ($leafname, $desc) = /^\s+(\S+)\s+(.*)/) {
 174             my $podname = $leafname;
 175             my $filename = "pod/$podname.pod";
 176             foreach (@paths) {
 177                 my ($re, $path) = @$_;
 178                 if ($leafname =~ $re) {
 179                     $podname = $path . $leafname;
 180                     $filename = "$podname.pod";
 181                     last;
 182                 }
 183             }
 184
 185             # Keep this compatible with pre-5.10
 186             my $flags = delete $flag_set{$leafname};
 187             $flags = $current_flags unless defined $flags;
 188
 189             my %flags;
 190             $flags{toc_omit} = 1 if $flags =~ tr/o//d;
 191             $flags{dual} = $podname ne $leafname;
 192
 193             $state{generated}{"$podname.pod"}++ if $flags =~ tr/g//d;
 194
 195             if ($flags =~ tr/r//d) {
 196                 my $readme = $podname;
 197                 $readme =~ s/^perl//;
 198                 $state{readmes}{$readme} = $desc;
 199                 $flags{readme} = 1;
 200             } else {
 201                 $state{pods}{$podname} = $desc;
 202             }
 203             my_die "Unknown flag found in section line: $_" if length $flags;
 204
 205             push @{$state{master}},
 206                 [$leafname, $filename, \%flags];
 207
 208             if ($podname eq 'perldelta') {
 209                 local $" = '.';
 210                 push @{$state{master}},
 211                     [$delta_leaf, "pod/$state{delta_target}"];
 212                 $state{pods}{$delta_leaf} = "Perl changes in version @want";
 213             }
 214
 215         } else {
 216             my_die("Malformed line: $_");
 217         }
 218     }
 219     close $master or my_die("close pod/perl.pod: $!");
 220     # This has to be special-cased somewhere. Turns out this is cleanest:
 221     push @{$state{master}}, ['a2p', 'x2p/a2p.pod', {toc_omit => 1}];
 222
 223     my_die("perl.pod sets flags for unknown pods: "
 224            . join ' ', sort keys %flag_set)
 225         if keys %flag_set;
 226 }
 227
 228 sub get_pod_metadata {
 229     # Do we expect to find generated pods on disk?
 230     my $permit_missing_generated = shift;
 231     # Do they want a consistency report?
 232     my $callback = shift;
 233     local $_;
 234
 235     __prime_state() unless $state{master};
 236     return \%state unless $callback;
 237
 238     my %BuildFiles;
 239
 240     foreach my $path (@_) {
 241         $path =~ m!([^/]+)$!;
 242         ++$BuildFiles{$1};
 243     }
 244
 245     # Sanity cross check
 246
 247     my (%disk_pods, %manipods, %manireadmes);
 248     my (%cpanpods, %cpanpods_leaf);
 249     my (%our_pods);
 250
 251     # There are files that we don't want to list in perl.pod.
 252     # Maybe the various stub manpages should be listed there.
 253     my %ignoredpods = map { ( "$_.pod" => 1 ) } qw( );
 254
 255     # Convert these to a list of filenames.
 256     ++$our_pods{"$_.pod"} foreach keys %{$state{pods}};
 257     foreach (@{$state{master}}) {
 258         ++$our_pods{"$_->[0].pod"}
 259             if $_->[2]{readme};
 260     }
 261
 262     opendir my $dh, 'pod';
 263     while (defined ($_ = readdir $dh)) {
 264         next unless /\.pod\z/;
 265         ++$disk_pods{$_};
 266     }
 267
 268     # Things we copy from won't be in perl.pod
 269     # Things we copy to won't be in MANIFEST
 270
 271     my $mani = open_or_die('MANIFEST');
 272     while (<$mani>) {
 273         chomp;
 274         s/\s+.*$//;
 275         if (m!^pod/([^.]+\.pod)!i) {
 276             ++$manipods{$1};
 277         } elsif (m!^README\.(\S+)!i) {
 278             next if $state{ignore}{$1};
 279             ++$manireadmes{"perl$1.pod"};
 280         } elsif (exists $our_pods{$_}) {
 281             ++$cpanpods{$_};
 282             m!([^/]+)$!;
 283             ++$cpanpods_leaf{$1};
 284             $disk_pods{$_}++
 285                 if -e $_;
 286         }
 287     }
 288     close $mani or my_die "close MANIFEST: $!\n";
 289
 290     # Are we running before known generated files have been generated?
 291     # (eg in a clean checkout)
 292     my %not_yet_there;
 293     if ($permit_missing_generated) {
 294         # If so, don't complain if these files aren't yet in place
 295         %not_yet_there = (%manireadmes, %{$state{generated}}, %{$state{copies}})
 296     }
 297
 298     my @inconsistent;
 299     foreach my $i (sort keys %disk_pods) {
 300         push @inconsistent, "$0: $i exists but is unknown by buildtoc\n"
 301             unless $our_pods{$i} || $ignoredpods{$i};
 302         push @inconsistent, "$0: $i exists but is unknown by MANIFEST\n"
 303             if !$BuildFiles{'MANIFEST'} # Ignore if we're rebuilding MANIFEST
 304                 && !$manipods{$i} && !$manireadmes{$i} && !$state{copies}{$i}
 305                     && !$state{generated}{$i} && !$cpanpods{$i};
 306     }
 307     foreach my $i (sort keys %our_pods) {
 308         push @inconsistent, "$0: $i is known by buildtoc but does not exist\n"
 309             unless $disk_pods{$i} or $BuildFiles{$i} or $not_yet_there{$i};
 310     }
 311     unless ($BuildFiles{'MANIFEST'}) {
 312         # Again, ignore these if we're about to rebuild MANIFEST
 313         foreach my $i (sort keys %manipods) {
 314             push @inconsistent, "$0: $i is known by MANIFEST but does not exist\n"
 315                 unless $disk_pods{$i};
 316             push @inconsistent, "$0: $i is known by MANIFEST but is marked as generated\n"
 317                 if $state{generated}{$i};
 318         }
 319     }
 320     &$callback(@inconsistent);
 321     return \%state;
 322 }
 323
 324 1;
 325
 326 # Local variables:
 327 # cperl-indent-level: 4
 328 # indent-tabs-mode: nil
 329 # End:
 330 #
 331 # ex: set ts=8 sts=4 sw=4 et: