Porting/pod_lib.pl

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4
   5 # make it clearer when we haven't run to completion, as we can be quite
   6 # noisy when things are working ok
   7
   8 sub my_die {
   9     print STDERR "$0: ", @_;
  10     print STDERR "\n" unless $_[-1] =~ /\n\z/;
  11     print STDERR "ABORTED\n";
  12     exit 255;
  13 }
  14
  15 sub open_or_die {
  16     my $filename = shift;
  17     open my $fh, '<', $filename or my_die "Can't open $filename: $!";
  18     return $fh;
  19 }
  20
  21 sub slurp_or_die {
  22     my $filename = shift;
  23     my $fh = open_or_die($filename);
  24     binmode $fh;
  25     local $/;
  26     my $contents = <$fh>;
  27     die "Can't read $filename: $!" unless defined $contents and close $fh;
  28     return $contents;
  29 }
  30
  31 sub write_or_die {
  32     my ($filename, $contents) = @_;
  33     open my $fh, '>', $filename or die "Can't open $filename for writing: $!";
  34     binmode $fh;
  35     print $fh $contents or die "Can't write to $filename: $!";
  36     close $fh or die "Can't close $filename: $!";
  37 }
  38
  39 sub get_pod_metadata {
  40     # Do we expect to find generated pods on disk?
  41     my $permit_missing_generated = shift;
  42     my %BuildFiles;
  43
  44     foreach my $path (@_) {
  45         $path =~ m!([^/]+)$!;
  46         ++$BuildFiles{$1};
  47     }
  48
  49     my %state =
  50         (
  51          # Don't copy these top level READMEs
  52          ignore =>
  53          {
  54           micro => 1,
  55           # vms => 1,
  56          },
  57      );
  58
  59     my $source = 'perldelta.pod';
  60     my $filename = "pod/$source";
  61     my $fh = open_or_die($filename);
  62     my $contents = do {local $/; <$fh>};
  63     my @want =
  64         $contents =~ /perldelta - what is new for perl v(5)\.(\d+)\.(\d+)\n/;
  65     die "Can't extract version from $filename" unless @want;
  66     $state{delta_target} = join '', 'perl', @want, 'delta.pod';
  67     $state{delta_version} = \@want;
  68
  69     # This way round so that keys can act as a MANIFEST skip list
  70     # Targets will always be in the pod directory. Currently we can only cope
  71     # with sources being in the same directory.
  72     $state{copies}{$state{delta_target}} = $source;
  73
  74
  75     # process pod.lst
  76     my %Readmepods;
  77     my $master = open_or_die('pod.lst');
  78
  79     foreach (<$master>) {
  80         next if /^\#/;
  81
  82         # At least one upper case letter somewhere in the first group
  83         if (/^(\S+)\s(.*)/ && $1 =~ tr/h//) {
  84             # it's a heading
  85             my $flags = $1;
  86             $flags =~ tr/h//d;
  87             my %flags = (header => 1);
  88             $flags{toc_omit} = 1 if $flags =~ tr/o//d;
  89             $flags{aux} = 1 if $flags =~ tr/a//d;
  90             my_die "Unknown flag found in heading line: $_" if length $flags;
  91
  92             push @{$state{master}}, [\%flags, $2];
  93         } elsif (/^(\S*)\s+(\S+)\s+(.*)/) {
  94             # it's a section
  95             my ($flags, $podname, $desc) = ($1, $2, $3);
  96             my $filename = "${podname}.pod";
  97             $filename = "pod/${filename}" if $filename !~ m{/};
  98
  99             my %flags = (indent => 0);
 100             $flags{indent} = $1 if $flags =~ s/(\d+)//;
 101             $flags{toc_omit} = 1 if $flags =~ tr/o//d;
 102             $flags{aux} = 1 if $flags =~ tr/a//d;
 103             $flags{perlpod_omit} = "$podname.pod" eq $state{delta_target};
 104
 105             $state{generated}{"$podname.pod"}++ if $flags =~ tr/g//d;
 106
 107             if ($flags =~ tr/r//d) {
 108                 my $readme = $podname;
 109                 $readme =~ s/^perl//;
 110                 $Readmepods{$podname} = $state{readmes}{$readme} = $desc;
 111                 $flags{readme} = 1;
 112             } elsif ($flags{aux}) {
 113                 $state{aux}{$podname} = $desc;
 114             } else {
 115                 $state{pods}{$podname} = $desc;
 116             }
 117             my_die "Unknown flag found in section line: $_" if length $flags;
 118             my ($leafname) = $podname =~ m!([^/]+)$!;
 119             push @{$state{master}},
 120                 [\%flags, $podname, $filename, $desc, $leafname];
 121         } elsif (/^$/) {
 122             push @{$state{master}}, undef;
 123         } else {
 124             my_die "Malformed line: $_" if $1 =~ tr/A-Z//;
 125         }
 126     }
 127     close $master or my_die "close pod.lst: $!";
 128
 129     # Sanity cross check
 130
 131     my (%disk_pods, %manipods, %manireadmes, %perlpods);
 132     my (%cpanpods, %cpanpods_leaf);
 133     my (%our_pods);
 134
 135     # These are stub files for deleted documents. We don't want them to show up
 136     # in perl.pod, they just exist so that if someone types "perldoc perltoot"
 137     # they get some sort of pointer to the new docs.
 138     my %ignoredpods
 139         = map { ( "$_.pod" => 1 ) } qw( perlboot perlbot perltooc perltoot );
 140
 141     # Convert these to a list of filenames.
 142     foreach (keys %{$state{pods}}, keys %Readmepods) {
 143         $our_pods{"$_.pod"}++;
 144     }
 145
 146     opendir my $dh, 'pod';
 147     while (defined ($_ = readdir $dh)) {
 148         next unless /\.pod\z/;
 149         ++$disk_pods{$_};
 150     }
 151
 152     # Things we copy from won't be in perl.pod
 153     # Things we copy to won't be in MANIFEST
 154
 155     my $mani = open_or_die('MANIFEST');
 156     while (<$mani>) {
 157         chomp;
 158         s/\s+.*$//;
 159         if (m!^pod/([^.]+\.pod)!i) {
 160             ++$manipods{$1};
 161         } elsif (m!^README\.(\S+)!i) {
 162             next if $state{ignore}{$1};
 163             ++$manireadmes{"perl$1.pod"};
 164         } elsif (exists $our_pods{$_}) {
 165             ++$cpanpods{$_};
 166             m!([^/]+)$!;
 167             ++$cpanpods_leaf{$1};
 168             $disk_pods{$_}++
 169                 if -e $_;
 170         }
 171     }
 172     close $mani or my_die "close MANIFEST: $!\n";
 173
 174     my $perlpod = open_or_die('pod/perl.pod');
 175     while (<$perlpod>) {
 176         if (/^For ease of access, /../^\(If you're intending /) {
 177             if (/^\s+(perl\S*)\s+\w/) {
 178                 ++$perlpods{"$1.pod"};
 179             }
 180         }
 181     }
 182     close $perlpod or my_die "close perlpod: $!\n";
 183     my_die "could not find the pod listing of perl.pod\n"
 184         unless %perlpods;
 185
 186     # Are we running before known generated files have been generated?
 187     # (eg in a clean checkout)
 188     my %not_yet_there;
 189     if ($permit_missing_generated) {
 190         # If so, don't complain if these files aren't yet in place
 191         %not_yet_there = (%manireadmes, %{$state{generated}}, %{$state{copies}})
 192     }
 193
 194     my @inconsistent;
 195     foreach my $i (sort keys %disk_pods) {
 196         push @inconsistent, "$0: $i exists but is unknown by buildtoc\n"
 197             unless $our_pods{$i};
 198         push @inconsistent, "$0: $i exists but is unknown by MANIFEST\n"
 199             if !$BuildFiles{'MANIFEST'} # Ignore if we're rebuilding MANIFEST
 200                 && !$manipods{$i} && !$manireadmes{$i} && !$state{copies}{$i}
 201                     && !$state{generated}{$i} && !$cpanpods{$i};
 202         push @inconsistent, "$0: $i exists but is unknown by perl.pod\n"
 203             if !$BuildFiles{'perl.pod'} # Ignore if we're rebuilding perl.pod
 204                 && !$perlpods{$i} && !exists $state{copies}{$i}
 205                     && !$cpanpods{$i} && !$ignoredpods{$i};
 206     }
 207     foreach my $i (sort keys %our_pods) {
 208         push @inconsistent, "$0: $i is known by buildtoc but does not exist\n"
 209             unless $disk_pods{$i} or $BuildFiles{$i} or $not_yet_there{$i};
 210     }
 211     unless ($BuildFiles{'MANIFEST'}) {
 212         # Again, ignore these if we're about to rebuild MANIFEST
 213         foreach my $i (sort keys %manipods) {
 214             push @inconsistent, "$0: $i is known by MANIFEST but does not exist\n"
 215                 unless $disk_pods{$i};
 216             push @inconsistent, "$0: $i is known by MANIFEST but is marked as generated\n"
 217                 if $state{generated}{$i};
 218         }
 219     }
 220     unless ($BuildFiles{'perl.pod'}) {
 221         # Again, ignore these if we're about to rebuild perl.pod
 222         foreach my $i (sort keys %perlpods) {
 223             push @inconsistent, "$0: $i is known by perl.pod but does not exist\n"
 224                 unless $disk_pods{$i} or $BuildFiles{$i} or $cpanpods_leaf{$i}
 225                     or $not_yet_there{$i};
 226         }
 227     }
 228     $state{inconsistent} = \@inconsistent;
 229     return \%state;
 230 }
 231
 232 1;
 233
 234 # Local variables:
 235 # cperl-indent-level: 4
 236 # indent-tabs-mode: nil
 237 # End:
 238 #
 239 # ex: set ts=8 sts=4 sw=4 et: