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/perl.pod
  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, MANIFEST are consistent, and regenerated
  18 #   files are up to date, die otherwise.
  19
  20 %Targets = (
  21             manifest => 'MANIFEST',
  22             vms => 'vms/descrip_mms.template',
  23             nmake => 'win32/Makefile',
  24             dmake => 'win32/makefile.mk',
  25             podmak => 'win32/pod.mak',
  26             unix => 'Makefile.SH',
  27             # plan9 =>  'plan9/mkfile',
  28            );
  29
  30 require 'Porting/pod_lib.pl';
  31 sub my_die;
  32
  33 # process command-line switches
  34 {
  35     my @files = keys %Targets;
  36     my $filesopts = join(" | ", map { "--build-$_" } "all", sort @files);
  37     my $showfiles;
  38     my %build_these;
  39     die "$0: Usage: $0 [--verbose] [--showfiles] [$filesopts]\n"
  40         unless GetOptions (verbose => \$Verbose,
  41                            showfiles => \$showfiles,
  42                            tap => \$Test,
  43                            map {+"build-$_", \$build_these{$_}} @files, 'all')
  44             && !@ARGV;
  45     if ($build_these{all}) {
  46         %Build = %Targets;
  47     } else {
  48         while (my ($file, $want) = each %build_these) {
  49             $Build{$file} = $Targets{$file} if $want;
  50         }
  51         # Default to --build-all if no targets given.
  52         %Build = %Targets if !%Build;
  53     }
  54     if ($showfiles) {
  55         print join(" ", sort { lc $a cmp lc $b } values %Build), "\n";
  56         exit(0);
  57     }
  58 }
  59
  60 if ($Verbose) {
  61     print "I will be building $_\n" foreach keys %Build;
  62 }
  63
  64 my $test = 1;
  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 = $Test
  69     ? get_pod_metadata(0, sub {
  70                            printf "1..%d\n", 1 + scalar keys %Build;
  71                            if (@_) {
  72                                print "not ok $test\n";
  73                                die @_;
  74                            }
  75                            print "ok $test\n";
  76                        })
  77     : get_pod_metadata(1, sub { warn @_ if @_ }, values %Build);
  78
  79 sub generate_manifest {
  80     # Annoyingly, unexpand doesn't consider it good form to replace a single
  81     # space before a tab with a tab
  82     # Annoyingly (2) it returns read only values.
  83     my @temp = unexpand (map {sprintf "%-32s%s", @$_} @_);
  84     map {s/ \t/\t\t/g; $_} @temp;
  85 }
  86
  87 sub generate_manifest_pod {
  88     generate_manifest map {["pod/$_.pod", $state->{pods}{$_}]}
  89         sort grep {
  90             !$state->{copies}{"$_.pod"}
  91                 && !$state->{generated}{"$_.pod"}
  92                     && !-e "$_.pod"
  93                 } keys %{$state->{pods}};
  94 }
  95
  96 sub generate_manifest_readme {
  97     generate_manifest sort {$a->[0] cmp $b->[0]}
  98         ["README.vms", "Notes about installing the VMS port"],
  99             map {["README.$_", $state->{readmes}{$_}]} keys %{$state->{readmes}};
 100 }
 101
 102 sub generate_nmake_1 {
 103     # XXX Fix this with File::Spec
 104     (map {sprintf "\tcopy ..\\README.%-8s ..\\pod\\perl$_.pod\n", $_}
 105      sort keys %{$state->{readmes}}),
 106          (map {"\tcopy ..\\pod\\$state->{copies}{$_} ..\\pod\\$_\n"}
 107           sort keys %{$state->{copies}});
 108 }
 109
 110 # This doesn't have a trailing newline
 111 sub generate_nmake_2 {
 112     # Spot the special case
 113     local $Text::Wrap::columns = 76;
 114     my $line = wrap ("\t    ", "\t    ",
 115                      join " ", sort(keys %{$state->{copies}},
 116                                     keys %{$state->{generated}},
 117                                     map {"perl$_.pod"} keys %{$state->{readmes}}));
 118     $line =~ s/$/ \\/mg;
 119     $line =~ s/ \\$//;
 120     $line;
 121 }
 122
 123 sub generate_pod_mak {
 124     my $variable = shift;
 125     my @lines;
 126     my $line = "\U$variable = " . join "\t\\\n\t",
 127         map {"$_.$variable"} sort grep { $_ !~ m{/} } keys %{$state->{pods}};
 128     # Special case
 129     $line =~ s/.*perltoc.html.*\n//m;
 130     $line;
 131 }
 132
 133 sub verify_contiguous {
 134     my ($name, $content, $what) = @_;
 135     my $sections = () = $content =~ m/\0+/g;
 136     croak("$0: $name contains no $what") if $sections < 1;
 137     croak("$0: $name contains discontiguous $what") if $sections > 1;
 138 }
 139
 140 sub do_manifest {
 141     my ($name, $prev) = @_;
 142     my @manifest =
 143         grep {! m!^pod/[^. \t]+\.pod.*!}
 144             grep {! m!^README\.(\S+)! || $state->{ignore}{$1}} split "\n", $prev;
 145     join "\n", (
 146                 # Dictionary order - fold and handle non-word chars as nothing
 147                 map  { $_->[0] }
 148                 sort { $a->[1] cmp $b->[1] || $a->[0] cmp $b->[0] }
 149                 map  { my $f = lc $_; $f =~ s/[^a-z0-9\s]//g; [ $_, $f ] }
 150                 @manifest,
 151                 &generate_manifest_pod(),
 152                 &generate_manifest_readme()), '';
 153 }
 154
 155 sub do_nmake {
 156     my ($name, $makefile) = @_;
 157     $makefile =~ s/^\tcopy \.\.\\README.*\n/\0/gm;
 158     verify_contiguous($name, $makefile, 'README copies');
 159     # Now remove the other copies that follow
 160     1 while $makefile =~ s/\0\tcopy .*\n/\0/gm;
 161     $makefile =~ s/\0+/join ("", &generate_nmake_1)/se;
 162
 163     $makefile =~ s{(-cd \$\(PODDIR\) && del /f[^\n]+).*?(-cd \.\.\\utils && del /f)}
 164                   {"$1\n" . &generate_nmake_2."\n\t$2"}se;
 165     $makefile;
 166 }
 167
 168 # shut up used only once warning
 169 *do_dmake = *do_dmake = \&do_nmake;
 170
 171 sub do_podmak {
 172     my ($name, $body) = @_;
 173     foreach my $variable (qw(pod man html tex)) {
 174         my_die "could not find $variable in $name"
 175             unless $body =~ s{\n\U$variable\E = (?:[^\n]*\\\n)*[^\n]*}
 176                              {"\n" . generate_pod_mak ($variable)}se;
 177     }
 178     $body;
 179 }
 180
 181 sub do_vms {
 182     my ($name, $makefile) = @_;
 183
 184     # Looking for the macro defining the current perldelta:
 185     #PERLDELTA_CURRENT = [.pod]perl5139delta.pod
 186
 187     $makefile =~ s{\nPERLDELTA_CURRENT\s+=\s+\Q[.pod]perl\E\d+delta\.pod\n}
 188                   {\0}sx;
 189     verify_contiguous($name, $makefile, 'current perldelta macro');
 190     $makefile =~ s/\0+/join "\n", '', "PERLDELTA_CURRENT = [.pod]$state->{delta_target}", ''/se;
 191
 192     $makefile;
 193 }
 194
 195 sub do_unix {
 196     my ($name, $makefile_SH) = @_;
 197
 198     $makefile_SH =~ s{^(perltoc_pod_prereqs = extra.pods).*}
 199                      {join ' ', $1, map "pod/$_",
 200                           sort(keys %{$state->{copies}},
 201                                grep {!/perltoc/} keys %{$state->{generated}})
 202                       }mge;
 203
 204     # pod/perl511delta.pod: pod/perldelta.pod
 205     #         cd pod && $(LNS) perldelta.pod perl511delta.pod
 206
 207     # although it seems that HP-UX make gets confused, always tried to
 208     # regenerate the symlink, and then the ln -s fails, as the target exists.
 209
 210     $makefile_SH =~ s!(
 211 pod/perl[a-z0-9_]+\.pod: pod/perl[a-z0-9_]+\.pod
 212         \$\(RMS\) pod/perl[a-z0-9_]+\.pod
 213         \$\(LNS\) perl[a-z0-9_]+\.pod pod/perl[a-z0-9_]+\.pod
 214 )+!\0!gm;
 215
 216     verify_contiguous($name, $makefile_SH, 'copy rules');
 217
 218     my @copy_rules = map "
 219 pod/$_: pod/$state->{copies}{$_}
 220         \$(RMS) pod/$_
 221         \$(LNS) $state->{copies}{$_} pod/$_
 222 ", keys %{$state->{copies}};
 223
 224     $makefile_SH =~ s/\0+/join '', @copy_rules/se;
 225     $makefile_SH;
 226 }
 227
 228 # Do stuff
 229 while (my ($target, $name) = each %Build) {
 230     print "Now processing $name\n" if $Verbose;
 231
 232     my $orig = slurp_or_die($name);
 233     my_die "$name contains NUL bytes" if $orig =~ /\0/;
 234
 235     my $new = do {
 236         no strict 'refs';
 237         &{"do_$target"}($target, $orig);
 238     };
 239
 240     if ($Test) {
 241         printf "%s %d # $name is up to date\n",
 242             $new eq $orig ? 'ok' : 'not ok',
 243                 ++$test;
 244         next;
 245     } elsif ($new eq $orig) {
 246         print "Was not modified\n"
 247             if $Verbose;
 248         next;
 249     }
 250
 251     my $mode = (stat $name)[2] // my_die "Can't stat $name: $!";
 252     rename $name, "$name.old" or my_die "Can't rename $name to $name.old: $!";
 253
 254     write_or_die($name, $new);
 255     chmod $mode & 0777, $name or my_die "can't chmod $mode $name: $!";
 256 }
 257
 258 # Local variables:
 259 # cperl-indent-level: 4
 260 # indent-tabs-mode: nil
 261 # End:
 262 #
 263 # ex: set ts=8 sts=4 sw=4 et: