This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Merge branch 'drolsky/release-5.15.6' into blead
[perl5.git] / 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 my $test = 1;
66 # For testing, generated files must be present and we're rebuilding nothing.
67 # For normal rebuilding, generated files may not be present, and we mute
68 # warnings about inconsistencies in any file we're about to rebuild.
69 my $state = $Test
70     ? get_pod_metadata(0, sub {
71                            printf "1..%d\n", 1 + scalar keys %Build;
72                            if (@_) {
73                                print "not ok $test\n";
74                                die @_;
75                            }
76                            print "ok $test\n";
77                        })
78     : get_pod_metadata(1, sub { warn @_ if @_ }, values %Build);
79
80 sub generate_perlpod {
81     my @output;
82     my $maxlength = 0;
83     foreach (@{$state->{master}}) {
84         my $flags = $_->[0];
85         next if $flags->{aux};
86         next if $flags->{perlpod_omit};
87
88         if (@$_ == 2) {
89             # Heading
90             push @output, "=head2 $_->[1]\n";
91         } elsif (@$_ == 5) {
92             # Section
93             my $start = " " x (4 + $flags->{indent}) . $_->[4];
94             $maxlength = length $start if length ($start) > $maxlength;
95             push @output, [$start, $_->[3]];
96         } elsif (@$_ == 0) {
97             # blank line
98             push @output, "\n";
99         } else {
100             my_die "Illegal length " . scalar @$_;
101         }
102     }
103     # want at least 2 spaces padding
104     $maxlength += 2;
105     $maxlength = ($maxlength + 3) & ~3;
106     # sprintf gives $1.....$2 where ... are spaces:
107     return unexpand (map {ref $_ ? sprintf "%-${maxlength}s%s\n", @$_ : $_}
108                      @output);
109 }
110
111 sub generate_manifest {
112     # Annoyingly, unexpand doesn't consider it good form to replace a single
113     # space before a tab with a tab
114     # Annoyingly (2) it returns read only values.
115     my @temp = unexpand (map {sprintf "%-32s%s", @$_} @_);
116     map {s/ \t/\t\t/g; $_} @temp;
117 }
118
119 sub generate_manifest_pod {
120     generate_manifest map {["pod/$_.pod", $state->{pods}{$_}]}
121         sort grep {
122             !$state->{copies}{"$_.pod"}
123                 && !$state->{generated}{"$_.pod"}
124                     && !-e "$_.pod"
125                 } keys %{$state->{pods}};
126 }
127
128 sub generate_manifest_readme {
129     generate_manifest sort {$a->[0] cmp $b->[0]}
130         ["README.vms", "Notes about installing the VMS port"],
131             map {["README.$_", $state->{readmes}{$_}]} keys %{$state->{readmes}};
132 }
133
134 sub generate_nmake_1 {
135     # XXX Fix this with File::Spec
136     (map {sprintf "\tcopy ..\\README.%-8s ..\\pod\\perl$_.pod\n", $_}
137      sort keys %{$state->{readmes}}),
138          (map {"\tcopy ..\\pod\\$state->{copies}{$_} ..\\pod\\$_\n"}
139           sort keys %{$state->{copies}});
140 }
141
142 # This doesn't have a trailing newline
143 sub generate_nmake_2 {
144     # Spot the special case
145     local $Text::Wrap::columns = 76;
146     my $line = wrap ("\t    ", "\t    ",
147                      join " ", sort(keys %{$state->{copies}},
148                                     keys %{$state->{generated}},
149                                     map {"perl$_.pod"} keys %{$state->{readmes}}));
150     $line =~ s/$/ \\/mg;
151     $line =~ s/ \\$//;
152     $line;
153 }
154
155 sub generate_pod_mak {
156     my $variable = shift;
157     my @lines;
158     my $line = "\U$variable = " . join "\t\\\n\t",
159         map {"$_.$variable"} sort grep { $_ !~ m{/} } keys %{$state->{pods}};
160     # Special case
161     $line =~ s/.*perltoc.html.*\n//m;
162     $line;
163 }
164
165 sub verify_contiguous {
166     my ($name, $content, $what) = @_;
167     my $sections = () = $content =~ m/\0+/g;
168     croak("$0: $name contains no $what") if $sections < 1;
169     croak("$0: $name contains discontiguous $what") if $sections > 1;
170 }
171
172 sub do_manifest {
173     my ($name, $prev) = @_;
174     my @manifest =
175         grep {! m!^pod/[^.]+\.pod.*!}
176             grep {! m!^README\.(\S+)! || $state->{ignore}{$1}} split "\n", $prev;
177     join "\n", (
178                 # Dictionary order - fold and handle non-word chars as nothing
179                 map  { $_->[0] }
180                 sort { $a->[1] cmp $b->[1] || $a->[0] cmp $b->[0] }
181                 map  { my $f = lc $_; $f =~ s/[^a-z0-9\s]//g; [ $_, $f ] }
182                 @manifest,
183                 &generate_manifest_pod(),
184                 &generate_manifest_readme()), '';
185 }
186
187 sub do_nmake {
188     my ($name, $makefile) = @_;
189     $makefile =~ s/^\tcopy \.\.\\README.*\n/\0/gm;
190     verify_contiguous($name, $makefile, 'README copies');
191     # Now remove the other copies that follow
192     1 while $makefile =~ s/\0\tcopy .*\n/\0/gm;
193     $makefile =~ s/\0+/join ("", &generate_nmake_1)/se;
194
195     $makefile =~ s{(-cd \$\(PODDIR\) && del /f[^\n]+).*?(-cd \.\.\\utils && del /f)}
196                   {"$1\n" . &generate_nmake_2."\n\t$2"}se;
197     $makefile;
198 }
199
200 # shut up used only once warning
201 *do_dmake = *do_dmake = \&do_nmake;
202
203 sub do_perlpod {
204     my ($name, $pod) = @_;
205
206     unless ($pod =~ s{(For\ ease\ of\ access,\ .*\n)
207                       (?:\s+[a-z]{4,}.*\n   #   fooo
208                       |=head.*\n            # =head foo
209                       |\s*\n                # blank line
210                    )+
211                  }
212                      {$1 . join "", &generate_perlpod}mxe) {
213         my_die "Failed to insert amendments in do_perlpod";
214     }
215     $pod;
216 }
217
218 sub do_podmak {
219     my ($name, $body) = @_;
220     foreach my $variable (qw(pod man html tex)) {
221         my_die "could not find $variable in $name"
222             unless $body =~ s{\n\U$variable\E = (?:[^\n]*\\\n)*[^\n]*}
223                              {"\n" . generate_pod_mak ($variable)}se;
224     }
225     $body;
226 }
227
228 sub do_vms {
229     my ($name, $makefile) = @_;
230
231     # Looking for the macro defining the current perldelta:
232     #PERLDELTA_CURRENT = [.pod]perl5139delta.pod
233
234     $makefile =~ s{\nPERLDELTA_CURRENT\s+=\s+\Q[.pod]perl\E\d+delta\.pod\n}
235                   {\0}sx;
236     verify_contiguous($name, $makefile, 'current perldelta macro');
237     $makefile =~ s/\0+/join "\n", '', "PERLDELTA_CURRENT = [.pod]$state->{delta_target}", ''/se;
238
239     $makefile;
240 }
241
242 sub do_unix {
243     my ($name, $makefile_SH) = @_;
244
245     $makefile_SH =~ s{^(perltoc_pod_prereqs = extra.pods).*}
246                      {join ' ', $1, map "pod/$_",
247                           sort(keys %{$state->{copies}},
248                                grep {!/perltoc/} keys %{$state->{generated}})
249                       }mge;
250
251     # pod/perl511delta.pod: pod/perldelta.pod
252     #         cd pod && $(LNS) perldelta.pod perl511delta.pod
253
254     $makefile_SH =~ s!(
255 pod/perl[a-z0-9_]+\.pod: pod/perl[a-z0-9_]+\.pod
256         \$\(LNS\) perl[a-z0-9_]+\.pod pod/perl[a-z0-9_]+\.pod
257 )+!\0!gm;
258
259     verify_contiguous($name, $makefile_SH, 'copy rules');
260
261     my @copy_rules = map "
262 pod/$_: pod/$state->{copies}{$_}
263         \$(LNS) $state->{copies}{$_} pod/$_
264 ", keys %{$state->{copies}};
265
266     $makefile_SH =~ s/\0+/join '', @copy_rules/se;
267     $makefile_SH;
268 }
269
270 # Do stuff
271 while (my ($target, $name) = each %Build) {
272     print "Now processing $name\n" if $Verbose;
273
274     my $orig = slurp_or_die($name);
275     my_die "$name contains NUL bytes" if $orig =~ /\0/;
276
277     my $new = do {
278         no strict 'refs';
279         &{"do_$target"}($target, $orig);
280     };
281
282     if ($Test) {
283         printf "%s %d # $name is up to date\n",
284             $new eq $orig ? 'ok' : 'not ok',
285                 ++$test;
286         next;
287     } elsif ($new eq $orig) {
288         print "Was not modified\n"
289             if $Verbose;
290         next;
291     }
292
293     my $mode = (stat $name)[2] // my_die "Can't stat $name: $!";
294     rename $name, "$name.old" or my_die "Can't rename $name to $name.old: $!";
295
296     write_or_die($name, $new);
297     chmod $mode & 0777, $name or my_die "can't chmod $mode $name: $!";
298 }
299
300 # Local variables:
301 # cperl-indent-level: 4
302 # indent-tabs-mode: nil
303 # End:
304 #
305 # ex: set ts=8 sts=4 sw=4 et: