| 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: |