Porting/pod_rules.pl

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use vars qw(%Build %Targets $Verbose $Test);
   5 use Text::Tabs;
   6 use Text::Wrap;
   7 use Getopt::Long;
   8 use Carp;
   9
  10 # Generate the sections of files listed in %Targets from pod.lst
  11 # Mostly these are rules in Makefiles
  12 #
  13 # --verbose gives slightly more output
  14 # --build-all tries to build everything
  15 # --build-foo updates foo as follows
  16 # --showfiles shows the files to be changed
  17 # --test exit if perl.pod, pod.lst, MANIFEST are consistent, and regenerated
  18 #   files are up to date, die otherwise.
  19
  20 %Targets = (
  21             manifest => 'MANIFEST',
  22             perlpod => 'pod/perl.pod',
  23             vms => 'vms/descrip_mms.template',
  24             nmake => 'win32/Makefile',
  25             dmake => 'win32/makefile.mk',
  26             podmak => 'win32/pod.mak',
  27             unix => 'Makefile.SH',
  28             # plan9 =>  'plan9/mkfile',
  29            );
  30
  31 require 'Porting/pod_lib.pl';
  32 sub my_die;
  33
  34 # process command-line switches
  35 {
  36     my @files = keys %Targets;
  37     my $filesopts = join(" | ", map { "--build-$_" } "all", sort @files);
  38     my $showfiles;
  39     my %build_these;
  40     die "$0: Usage: $0 [--verbose] [--showfiles] [$filesopts]\n"
  41         unless GetOptions (verbose => \$Verbose,
  42                            showfiles => \$showfiles,
  43                            tap => \$Test,
  44                            map {+"build-$_", \$build_these{$_}} @files, 'all')
  45             && !@ARGV;
  46     if ($build_these{all}) {
  47         %Build = %Targets;
  48     } else {
  49         while (my ($file, $want) = each %build_these) {
  50             $Build{$file} = $Targets{$file} if $want;
  51         }
  52         # Default to --build-all if no targets given.
  53         %Build = %Targets if !%Build;
  54     }
  55     if ($showfiles) {
  56         print join(" ", sort { lc $a cmp lc $b } values %Build), "\n";
  57         exit(0);
  58     }
  59 }
  60
  61 if ($Verbose) {
  62     print "I will be building $_\n" foreach keys %Build;
  63 }
  64
  65 # For testing, generated files must be present and we're rebuilding nothing.
  66 # For normal rebuilding, generated files may not be present, and we mute
  67 # warnings about inconsistencies in any file we're about to rebuild.
  68 my $state = get_pod_metadata($Test ? () : (1, values %Build));
  69
  70 my $test = 1;
  71 if ($Test) {
  72     printf "1..%d\n", 1 + scalar keys %Build;
  73     if (@{$state->{inconsistent}}) {
  74         print "not ok $test\n";
  75         die @{$state->{inconsistent}};
  76     }
  77     print "ok $test\n";
  78 }
  79 else {
  80     warn @{$state->{inconsistent}} if @{$state->{inconsistent}};
  81 }
  82
  83 sub generate_perlpod {
  84     my @output;
  85     my $maxlength = 0;
  86     foreach (@{$state->{master}}) {
  87         my $flags = $_->[0];
  88         next if $flags->{aux};
  89         next if $flags->{perlpod_omit};
  90
  91         if (@$_ == 2) {
  92             # Heading
  93             push @output, "=head2 $_->[1]\n";
  94         } elsif (@$_ == 5) {
  95             # Section
  96             my $start = " " x (4 + $flags->{indent}) . $_->[4];
  97             $maxlength = length $start if length ($start) > $maxlength;
  98             push @output, [$start, $_->[3]];
  99         } elsif (@$_ == 0) {
 100             # blank line
 101             push @output, "\n";
 102         } else {
 103             my_die "Illegal length " . scalar @$_;
 104         }
 105     }
 106     # want at least 2 spaces padding
 107     $maxlength += 2;
 108     $maxlength = ($maxlength + 3) & ~3;
 109     # sprintf gives $1.....$2 where ... are spaces:
 110     return unexpand (map {ref $_ ? sprintf "%-${maxlength}s%s\n", @$_ : $_}
 111                      @output);
 112 }
 113
 114 sub generate_manifest {
 115     # Annoyingly, unexpand doesn't consider it good form to replace a single
 116     # space before a tab with a tab
 117     # Annoyingly (2) it returns read only values.
 118     my @temp = unexpand (map {sprintf "%-32s%s", @$_} @_);
 119     map {s/ \t/\t\t/g; $_} @temp;
 120 }
 121
 122 sub generate_manifest_pod {
 123     generate_manifest map {["pod/$_.pod", $state->{pods}{$_}]}
 124         sort grep {
 125             !$state->{copies}{"$_.pod"}
 126                 && !$state->{generated}{"$_.pod"}
 127                     && !-e "$_.pod"
 128                 } keys %{$state->{pods}};
 129 }
 130
 131 sub generate_manifest_readme {
 132     generate_manifest sort {$a->[0] cmp $b->[0]}
 133         ["README.vms", "Notes about installing the VMS port"],
 134             map {["README.$_", $state->{readmes}{$_}]} keys %{$state->{readmes}};
 135 }
 136
 137 sub generate_nmake_1 {
 138     # XXX Fix this with File::Spec
 139     (map {sprintf "\tcopy ..\\README.%-8s ..\\pod\\perl$_.pod\n", $_}
 140      sort keys %{$state->{readmes}}),
 141          (map {"\tcopy ..\\pod\\$state->{copies}{$_} ..\\pod\\$_\n"}
 142           sort keys %{$state->{copies}});
 143 }
 144
 145 # This doesn't have a trailing newline
 146 sub generate_nmake_2 {
 147     # Spot the special case
 148     local $Text::Wrap::columns = 76;
 149     my $line = wrap ("\t    ", "\t    ",
 150                      join " ", sort(keys %{$state->{copies}},
 151                                     keys %{$state->{generated}},
 152                                     map {"perl$_.pod"} keys %{$state->{readmes}}));
 153     $line =~ s/$/ \\/mg;
 154     $line =~ s/ \\$//;
 155     $line;
 156 }
 157
 158 sub generate_pod_mak {
 159     my $variable = shift;
 160     my @lines;
 161     my $line = "\U$variable = " . join "\t\\\n\t",
 162         map {"$_.$variable"} sort grep { $_ !~ m{/} } keys %{$state->{pods}};
 163     # Special case
 164     $line =~ s/.*perltoc.html.*\n//m;
 165     $line;
 166 }
 167
 168 sub verify_contiguous {
 169     my ($name, $content, $what) = @_;
 170     my $sections = () = $content =~ m/\0+/g;
 171     croak("$0: $name contains no $what") if $sections < 1;
 172     croak("$0: $name contains discontiguous $what") if $sections > 1;
 173 }
 174
 175 sub do_manifest {
 176     my ($name, $prev) = @_;
 177     my @manifest =
 178         grep {! m!^pod/[^.]+\.pod.*!}
 179             grep {! m!^README\.(\S+)! || $state->{ignore}{$1}} split "\n", $prev;
 180     join "\n", (
 181                 # Dictionary order - fold and handle non-word chars as nothing
 182                 map  { $_->[0] }
 183                 sort { $a->[1] cmp $b->[1] || $a->[0] cmp $b->[0] }
 184                 map  { my $f = lc $_; $f =~ s/[^a-z0-9\s]//g; [ $_, $f ] }
 185                 @manifest,
 186                 &generate_manifest_pod(),
 187                 &generate_manifest_readme()), '';
 188 }
 189
 190 sub do_nmake {
 191     my ($name, $makefile) = @_;
 192     $makefile =~ s/^\tcopy \.\.\\README.*\n/\0/gm;
 193     verify_contiguous($name, $makefile, 'README copies');
 194     # Now remove the other copies that follow
 195     1 while $makefile =~ s/\0\tcopy .*\n/\0/gm;
 196     $makefile =~ s/\0+/join ("", &generate_nmake_1)/se;
 197
 198     $makefile =~ s{(-cd \$\(PODDIR\) && del /f[^\n]+).*?(-cd \.\.\\utils && del /f)}
 199                   {"$1\n" . &generate_nmake_2."\n\t$2"}se;
 200     $makefile;
 201 }
 202
 203 # shut up used only once warning
 204 *do_dmake = *do_dmake = \&do_nmake;
 205
 206 sub do_perlpod {
 207     my ($name, $pod) = @_;
 208
 209     unless ($pod =~ s{(For\ ease\ of\ access,\ .*\n)
 210                       (?:\s+[a-z]{4,}.*\n   #   fooo
 211                       |=head.*\n            # =head foo
 212                       |\s*\n                # blank line
 213                    )+
 214                  }
 215                      {$1 . join "", &generate_perlpod}mxe) {
 216         my_die "Failed to insert amendments in do_perlpod";
 217     }
 218     $pod;
 219 }
 220
 221 sub do_podmak {
 222     my ($name, $body) = @_;
 223     foreach my $variable (qw(pod man html tex)) {
 224         my_die "could not find $variable in $name"
 225             unless $body =~ s{\n\U$variable\E = (?:[^\n]*\\\n)*[^\n]*}
 226                              {"\n" . generate_pod_mak ($variable)}se;
 227     }
 228     $body;
 229 }
 230
 231 sub do_vms {
 232     my ($name, $makefile) = @_;
 233
 234     # Looking for the macro defining the current perldelta:
 235     #PERLDELTA_CURRENT = [.pod]perl5139delta.pod
 236
 237     $makefile =~ s{\nPERLDELTA_CURRENT\s+=\s+\Q[.pod]perl\E\d+delta\.pod\n}
 238                   {\0}sx;
 239     verify_contiguous($name, $makefile, 'current perldelta macro');
 240     $makefile =~ s/\0+/join "\n", '', "PERLDELTA_CURRENT = [.pod]$state->{delta_target}", ''/se;
 241
 242     $makefile;
 243 }
 244
 245 sub do_unix {
 246     my ($name, $makefile_SH) = @_;
 247
 248     $makefile_SH =~ s{^(perltoc_pod_prereqs = extra.pods).*}
 249                      {join ' ', $1, map "pod/$_",
 250                           sort(keys %{$state->{copies}},
 251                                grep {!/perltoc/} keys %{$state->{generated}})
 252                       }mge;
 253
 254     # pod/perl511delta.pod: pod/perldelta.pod
 255     #         cd pod && $(LNS) perldelta.pod perl511delta.pod
 256
 257     $makefile_SH =~ s!(
 258 pod/perl[a-z0-9_]+\.pod: pod/perl[a-z0-9_]+\.pod
 259         \$\(LNS\) perl[a-z0-9_]+\.pod pod/perl[a-z0-9_]+\.pod
 260 )+!\0!gm;
 261
 262     verify_contiguous($name, $makefile_SH, 'copy rules');
 263
 264     my @copy_rules = map "
 265 pod/$_: pod/$state->{copies}{$_}
 266         \$(LNS) $state->{copies}{$_} pod/$_
 267 ", keys %{$state->{copies}};
 268
 269     $makefile_SH =~ s/\0+/join '', @copy_rules/se;
 270     $makefile_SH;
 271 }
 272
 273 # Do stuff
 274 while (my ($target, $name) = each %Targets) {
 275     print "Now processing $name\n" if $Verbose;
 276
 277     my $orig = slurp_or_die($name);
 278     my_die "$name contains NUL bytes" if $orig =~ /\0/;
 279
 280     my $new = do {
 281         no strict 'refs';
 282         &{"do_$target"}($target, $orig);
 283     };
 284
 285     if ($Test) {
 286         printf "%s %d # $name is up to date\n",
 287             $new eq $orig ? 'ok' : 'not ok',
 288                 ++$test;
 289         next;
 290     } elsif ($new eq $orig) {
 291         print "Was not modified\n"
 292             if $Verbose;
 293         next;
 294     }
 295
 296     my $mode = (stat $name)[2] // my_die "Can't stat $name: $!";
 297     rename $name, "$name.old" or my_die "Can't rename $name to $name.old: $!";
 298
 299     write_or_die($name, $new);
 300     chmod $mode & 0777, $name or my_die "can't chmod $mode $name: $!";
 301 }
 302
 303 # Local variables:
 304 # cperl-indent-level: 4
 305 # indent-tabs-mode: nil
 306 # End:
 307 #
 308 # ex: set ts=8 sts=4 sw=4 et: