pod/buildtoc.PL

   1 #!/usr/local/bin/perl
   2
   3 use Config;
   4 use File::Basename qw(&basename &dirname);
   5 use Cwd;
   6
   7 # List explicitly here the variables you want Configure to
   8 # generate.  Metaconfig only looks for shell variables, so you
   9 # have to mention them as if they were shell variables, not
  10 # %Config entries.  Thus you write
  11 #  $startperl
  12 # to ensure Configure will look for $Config{startperl}.
  13
  14 # This forces PL files to create target in same directory as PL file.
  15 # This is so that make depend always knows where to find PL derivatives.
  16 $origdir = cwd;
  17 chdir(dirname($0));
  18 ($file = basename($0)) =~ s/\.PL$//;
  19 $file =~ s/\.pl$// if ($^O eq 'os2' or $^O eq 'dos');  # "case-forgiving"
  20 $file =~ s/\.pl$/.com/ if ($^O eq 'VMS');              # "case-forgiving"
  21
  22 open OUT,">$file" or die "Can't create $file: $!";
  23
  24 print "Extracting $file (with variable substitutions)\n";
  25
  26 # In this section, perl variables will be expanded during extraction.
  27 # You can use $Config{...} to use Configure variables.
  28
  29 print OUT <<"!GROK!THIS!";
  30 $Config{'startperl'}
  31     eval 'exec perl -S \$0 "\$@"'
  32         if 0;
  33 !GROK!THIS!
  34
  35 # In the following, perl variables are not expanded during extraction.
  36
  37 print OUT <<'!NO!SUBS!';
  38
  39 #
  40 # buildtoc
  41 #
  42 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
  43 # This file is autogenerated by buildtoc.PL.
  44 # Edit that file and run it to effect changes.
  45 #
  46 # Builds perltoc.pod and sanity checks the list of pods against all
  47 # of the MANIFEST, perl.pod, and ourselves.
  48 #
  49
  50 use File::Find;
  51 use Cwd;
  52 use Text::Wrap;
  53
  54 @PODS = glob("*.pod");
  55
  56 sub output ($);
  57
  58 if (-d "pod") {
  59   die "$0: failed to chdir('pod'): $!\n" unless chdir("pod");
  60 }
  61
  62 @ARCHPODS = qw(
  63     perlaix
  64     perlapollo
  65     perlamiga
  66     perlbeos
  67     perlbs2000
  68     perlce
  69     perlcygwin
  70     perldgux
  71     perldos
  72     perlepoc
  73     perlhpux
  74     perlhurd
  75     perlmachten
  76     perlmacos
  77     perlmint
  78     perlmpeix
  79     perlnetware
  80     perlos2
  81     perlos390
  82     perlqnx
  83     perlplan9
  84     perlsolaris
  85     perltru64
  86     perluts
  87     perlvmesa
  88     perlvms
  89     perlvos
  90     perlwin32
  91           );
  92
  93 @pods =
  94   (
  95     qw(
  96
  97     perl
  98     perlfaq
  99     perltoc
 100     perlbook
 101
 102     perlsyn
 103     perldata
 104     perlop
 105     perlsub
 106     perlfunc
 107     perlreftut
 108     perldsc
 109     perlrequick
 110     perlpod
 111     perlstyle
 112     perltrap
 113
 114     perlrun
 115     perldiag
 116     perllexwarn
 117     perldebtut
 118     perldebug
 119
 120     perlvar
 121     perllol
 122     perlopentut
 123     perlretut
 124
 125     perlre
 126     perlref
 127
 128     perlform
 129
 130     perlboot
 131     perltoot
 132     perltootc
 133     perlobj
 134     perlbot
 135     perltie
 136
 137     perlipc
 138     perlfork
 139     perlnumber
 140
 141     perlthrtut
 142     perlothrtut
 143
 144     perlport
 145     perllocale
 146     perlunicode
 147     perlebcdic
 148
 149     perlsec
 150
 151     perlmod
 152     perlmodlib
 153     perlmodinstall
 154     perlnewmod
 155
 156     perlfaq1
 157     perlfaq2
 158     perlfaq3
 159     perlfaq4
 160     perlfaq5
 161     perlfaq6
 162     perlfaq7
 163     perlfaq8
 164     perlfaq9
 165
 166     perlcompile
 167
 168     perlembed
 169     perldebguts
 170     perlxstut
 171     perlxs
 172     perlclib
 173     perlguts
 174     perlcall
 175     perlutil
 176     perlfilter
 177     perldbmfilter
 178     perlapi
 179     perlintern
 180     perliol
 181     perlapio
 182     perltodo
 183     perlhack
 184
 185     perlhist
 186     perldelta
 187     perl572delta
 188     perl571delta
 189     perl570delta
 190     perl56delta
 191     perl5005delta
 192     perl5004delta
 193
 194     ),
 195
 196     @ARCHPODS
 197
 198   );
 199
 200 for (@ARCHPODS) { s/$/.pod/ }
 201 @ARCHPODS{@ARCHPODS} = ();
 202
 203 for (@pods) { s/$/.pod/ }
 204 @pods{@pods} = ();
 205 @PODS{@PODS} = ();
 206
 207 open(MANI, "../MANIFEST") || die "$0: opening ../MANIFEST failed: $!";
 208 while (<MANI>) {
 209   if (m!^pod/([^.]+\.pod)\s+!i) {
 210      push @MANIPODS, $1;
 211   }
 212 }
 213 close(MANI);
 214 @MANIPODS{@MANIPODS} = ();
 215
 216 open(PERLPOD, "perl.pod") || die "$0: opening perl.pod failed: $!\n";
 217 while (<PERLPOD>) {
 218   if (/^For ease of access, /../^\(If you're intending /) {
 219         if (/^\s+(perl\S*)\s+\w/) {
 220                 push @PERLPODS, "$1.pod";
 221         }
 222   }
 223 }
 224 close(PERLPOD);
 225 die "$0: could not find the pod listing of perl.pod\n"
 226   unless @PERLPODS;
 227 @PERLPODS{@PERLPODS} = ();
 228
 229 # Cross-check against ourselves
 230 # Cross-check against the MANIFEST
 231 # Cross-check against the perl.pod
 232
 233 foreach my $i (sort keys %PODS) {
 234   warn "$0: $i exists but is unknown by buildtoc\n"
 235         unless exists $pods{$i};
 236   warn "$0: $i exists but is unknown by ../MANIFEST\n"
 237         if !exists $MANIPODS{$i} && !exists $ARCHPODS{$i};
 238   warn "$0: $i exists but is unknown by perl.pod\n"
 239         unless exists $PERLPODS{$i};
 240 }
 241 foreach my $i (sort keys %pods) {
 242   warn "$0: $i is known by buildtoc but does not exist\n"
 243         unless exists $PODS{$i};
 244 }
 245 foreach my $i (sort keys %MANIPODS) {
 246   warn "$0: $i is known by ../MANIFEST but does not exist\n"
 247         unless exists $PODS{$i};
 248 }
 249 foreach my $i (sort keys %PERLPODS) {
 250   warn "$0: $i is known by perl.pod but does not exist\n"
 251         unless exists $PODS{$i};
 252 }
 253
 254 # We are ready to rock.
 255 open(OUT, ">perltoc.pod") || die "$0: creating perltoc.pod failed: $!";
 256
 257 $/ = '';
 258 @ARGV = @pods;
 259
 260 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
 261
 262         =head1 NAME
 263
 264         perltoc - perl documentation table of contents
 265
 266         =head1 DESCRIPTION
 267
 268         This page provides a brief table of contents for the rest of the Perl
 269         documentation set.  It is meant to be scanned quickly or grepped
 270         through to locate the proper section you're looking for.
 271
 272         =head1 BASIC DOCUMENTATION
 273
 274 EOPOD2B
 275 #' make emacs happy
 276
 277 podset(@pods);
 278
 279 find \&getpods => qw(../lib ../ext);
 280
 281 sub getpods {
 282     if (/\.p(od|m)$/) {
 283         # Skip .pm files that have corresponding .pod files, and Functions.pm.
 284         return if /(.*)\.pm$/ && -f "$1.pod";
 285         my $file = $File::Find::name;
 286         return if $file eq '../lib/Pod/Functions.pm'; # Used only by pod itself
 287         return if $file =~ m!lib/Attribute/Handlers/demo/!;
 288
 289         die "tut $name" if $file =~ /TUT/;
 290         unless (open (F, "< $_\0")) {
 291             warn "bogus <$file>: $!";
 292             system "ls", "-l", $file;
 293         }
 294         else {
 295             my $line;
 296             while ($line = <F>) {
 297                 if ($line =~ /^=head1\s+NAME\b/) {
 298                     push @modpods, $file;
 299                     #warn "GOOD $file\n";
 300                     return;
 301                 }
 302             }
 303             warn "$0: $file: cannot find =head1 NAME\n";
 304         }
 305     }
 306 }
 307
 308 die "no pods" unless @modpods;
 309
 310 for (@modpods) {
 311     #($name) = /(\w+)\.p(m|od)$/;
 312     $name = path2modname($_);
 313     if ($name =~ /^[a-z]/) {
 314         push @pragmata, $_;
 315     } else {
 316         if ($done{$name}++) {
 317             # warn "already did $_\n";
 318             next;
 319         }
 320         push @modules, $_;
 321         push @modname, $name;
 322     }
 323 }
 324
 325 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
 326
 327
 328
 329         =head1 PRAGMA DOCUMENTATION
 330
 331 EOPOD2B
 332
 333 podset(sort @pragmata);
 334
 335 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
 336
 337
 338
 339         =head1 MODULE DOCUMENTATION
 340
 341 EOPOD2B
 342
 343 podset( @modules[ sort { $modname[$a] cmp $modname[$b] } 0 .. $#modules ] );
 344
 345 ($_= <<EOPOD2B) =~ s/^\t//gm;
 346
 347
 348         =head1 AUXILIARY DOCUMENTATION
 349
 350         Here should be listed all the extra programs' documentation, but they
 351         don't all have manual pages yet:
 352
 353         =over 4
 354
 355         =item a2p
 356
 357         =item s2p
 358
 359         =item find2perl
 360
 361         =item h2ph
 362
 363         =item c2ph
 364
 365         =item h2xs
 366
 367         =item xsubpp
 368
 369         =item pod2man
 370
 371         =item wrapsuid
 372
 373         =back
 374
 375         =head1 AUTHOR
 376
 377         Larry Wall <F<larry\@wall.org>>, with the help of oodles
 378         of other folks.
 379
 380
 381 EOPOD2B
 382 output $_;
 383 output "\n";                    # flush $LINE
 384 exit;
 385
 386 sub podset {
 387     local @ARGV = @_;
 388
 389     while(<>) {
 390         if (s/^=head1 (NAME)\s*/=head2 /) {
 391             $pod = path2modname($ARGV);
 392             unhead1();
 393             output "\n \n\n=head2 ";
 394             $_ = <>;
 395             if ( /^\s*$pod\b/ ) {
 396                 s/$pod\.pm/$pod/;       # '.pm' in NAME !?
 397                 output $_;
 398             } else {
 399                 s/^/$pod, /;
 400                 output $_;
 401             }
 402             next;
 403         }
 404         if (s/^=head1 (.*)/=item $1/) {
 405             unhead2();
 406             output "=over 4\n\n" unless $inhead1;
 407             $inhead1 = 1;
 408             output $_; nl(); next;
 409         }
 410         if (s/^=head2 (.*)/=item $1/) {
 411             unitem();
 412             output "=over 4\n\n" unless $inhead2;
 413             $inhead2 = 1;
 414             output $_; nl(); next;
 415         }
 416         if (s/^=item ([^=].*)/$1/) {
 417             next if $pod eq 'perldiag';
 418             s/^\s*\*\s*$// && next;
 419             s/^\s*\*\s*//;
 420             s/\n/ /g;
 421             s/\s+$//;
 422             next if /^[\d.]+$/;
 423             next if $pod eq 'perlmodlib' && /^ftp:/;
 424             ##print "=over 4\n\n" unless $initem;
 425             output ", " if $initem;
 426             $initem = 1;
 427             s/\.$//;
 428             s/^-X\b/-I<X>/;
 429             output $_; next;
 430         }
 431         if (s/^=cut\s*\n//) {
 432             unhead1();
 433             next;
 434         }
 435     }
 436 }
 437
 438 sub path2modname {
 439     local $_ = shift;
 440     s/\.p(m|od)$//;
 441     s-.*?/(lib|ext)/--;
 442     s-/-::-g;
 443     s/(\w+)::\1/$1/;
 444     return $_;
 445 }
 446
 447 sub unhead1 {
 448     unhead2();
 449     if ($inhead1) {
 450         output "\n\n=back\n\n";
 451     }
 452     $inhead1 = 0;
 453 }
 454
 455 sub unhead2 {
 456     unitem();
 457     if ($inhead2) {
 458         output "\n\n=back\n\n";
 459     }
 460     $inhead2 = 0;
 461 }
 462
 463 sub unitem {
 464     if ($initem) {
 465         output "\n\n";
 466         ##print "\n\n=back\n\n";
 467     }
 468     $initem = 0;
 469 }
 470
 471 sub nl {
 472     output "\n";
 473 }
 474
 475 my $NEWLINE;    # how many newlines have we seen recently
 476 my $LINE;       # what remains to be printed
 477
 478 sub output ($) {
 479     for (split /(\n)/, shift) {
 480         if ($_ eq "\n") {
 481             if ($LINE) {
 482                 print OUT wrap('', '', $LINE);
 483                 $LINE = '';
 484             }
 485             if ($NEWLINE < 2) {
 486                 print OUT;
 487                 $NEWLINE++;
 488             }
 489         }
 490         elsif (/\S/ && length) {
 491             $LINE .= $_;
 492             $NEWLINE = 0;
 493         }
 494     }
 495 }
 496
 497 !NO!SUBS!
 498
 499 close OUT or die "Can't close $file: $!";
 500 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 501 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
 502 chdir $origdir;