This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Refactor pod_rules.pl and buildtoc to use new functions in pod_lib.pl
[perl5.git] / Porting / pod_rules.pl
CommitLineData
b78c1104
NC
1#!/usr/bin/perl -w
2
3use strict;
4use vars qw(%Build %Targets $Verbose $Test);
5use Text::Tabs;
6use Text::Wrap;
7use Getopt::Long;
8use 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
31require 'Porting/pod_lib.pl';
32sub 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
61if ($Verbose) {
62 print "I will be building $_\n" foreach keys %Build;
63}
64
9e241592
NC
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.
68my $state = get_pod_metadata($Test ? () : (1, values %Build));
b78c1104
NC
69
70my $test = 1;
71if ($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}
79else {
80 warn @{$state->{inconsistent}} if @{$state->{inconsistent}};
81}
82
83sub 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
114sub 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
122sub 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
131sub 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
137sub 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
146sub 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
158sub 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
168sub 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
175sub 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
190sub 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
206sub 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
221sub 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
231sub 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
245sub 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!(
258pod/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 "
265pod/$_: 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
274while (my ($target, $name) = each %Targets) {
275 print "Now processing $name\n" if $Verbose;
276
3b0c5c72 277 my $orig = slurp_or_die($name);
b78c1104
NC
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
3b0c5c72 299 write_or_die($name, $new);
b78c1104
NC
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: