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     perltooc
 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     perlmodinstall
 153     perlmodlib
 154     perlmodstyle
 155     perlnewmod
 156
 157     perlfaq1
 158     perlfaq2
 159     perlfaq3
 160     perlfaq4
 161     perlfaq5
 162     perlfaq6
 163     perlfaq7
 164     perlfaq8
 165     perlfaq9
 166
 167     perlcompile
 168
 169     perlembed
 170     perldebguts
 171     perlxstut
 172     perlxs
 173     perlclib
 174     perlguts
 175     perlcall
 176     perlutil
 177     perlfilter
 178     perldbmfilter
 179     perlapi
 180     perlintern
 181     perliol
 182     perlapio
 183     perltodo
 184     perlhack
 185
 186     perlhist
 187     perldelta
 188     perl572delta
 189     perl571delta
 190     perl570delta
 191     perl56delta
 192     perl5005delta
 193     perl5004delta
 194
 195     ),
 196
 197     @ARCHPODS
 198
 199   );
 200
 201 for (@ARCHPODS) { s/$/.pod/ }
 202 @ARCHPODS{@ARCHPODS} = ();
 203
 204 for (@pods) { s/$/.pod/ }
 205 @pods{@pods} = ();
 206 @PODS{@PODS} = ();
 207
 208 open(MANI, "../MANIFEST") || die "$0: opening ../MANIFEST failed: $!";
 209 while (<MANI>) {
 210   if (m!^pod/([^.]+\.pod)\s+!i) {
 211      push @MANIPODS, $1;
 212   }
 213 }
 214 close(MANI);
 215 @MANIPODS{@MANIPODS} = ();
 216
 217 open(PERLPOD, "perl.pod") || die "$0: opening perl.pod failed: $!\n";
 218 while (<PERLPOD>) {
 219   if (/^For ease of access, /../^\(If you're intending /) {
 220         if (/^\s+(perl\S*)\s+\w/) {
 221                 push @PERLPODS, "$1.pod";
 222         }
 223   }
 224 }
 225 close(PERLPOD);
 226 die "$0: could not find the pod listing of perl.pod\n"
 227   unless @PERLPODS;
 228 @PERLPODS{@PERLPODS} = ();
 229
 230 # Cross-check against ourselves
 231 # Cross-check against the MANIFEST
 232 # Cross-check against the perl.pod
 233
 234 foreach my $i (sort keys %PODS) {
 235   warn "$0: $i exists but is unknown by buildtoc\n"
 236         unless exists $pods{$i};
 237   warn "$0: $i exists but is unknown by ../MANIFEST\n"
 238         if !exists $MANIPODS{$i} && !exists $ARCHPODS{$i};
 239   warn "$0: $i exists but is unknown by perl.pod\n"
 240         unless exists $PERLPODS{$i};
 241 }
 242 foreach my $i (sort keys %pods) {
 243   warn "$0: $i is known by buildtoc but does not exist\n"
 244         unless exists $PODS{$i};
 245 }
 246 foreach my $i (sort keys %MANIPODS) {
 247   warn "$0: $i is known by ../MANIFEST but does not exist\n"
 248         unless exists $PODS{$i};
 249 }
 250 foreach my $i (sort keys %PERLPODS) {
 251   warn "$0: $i is known by perl.pod but does not exist\n"
 252         unless exists $PODS{$i};
 253 }
 254
 255 # We are ready to rock.
 256 open(OUT, ">perltoc.pod") || die "$0: creating perltoc.pod failed: $!";
 257
 258 $/ = '';
 259 @ARGV = @pods;
 260
 261 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
 262
 263         =head1 NAME
 264
 265         perltoc - perl documentation table of contents
 266
 267         =head1 DESCRIPTION
 268
 269         This page provides a brief table of contents for the rest of the Perl
 270         documentation set.  It is meant to be scanned quickly or grepped
 271         through to locate the proper section you're looking for.
 272
 273         =head1 BASIC DOCUMENTATION
 274
 275 EOPOD2B
 276 #' make emacs happy
 277
 278 podset(@pods);
 279
 280 find \&getpods => qw(../lib ../ext);
 281
 282 sub getpods {
 283     if (/\.p(od|m)$/) {
 284         # Skip .pm files that have corresponding .pod files, and Functions.pm.
 285         return if /(.*)\.pm$/ && -f "$1.pod";
 286         my $file = $File::Find::name;
 287         return if $file eq '../lib/Pod/Functions.pm'; # Used only by pod itself
 288         return if $file =~ m!lib/Attribute/Handlers/demo/!;
 289
 290         die "tut $name" if $file =~ /TUT/;
 291         unless (open (F, "< $_\0")) {
 292             warn "bogus <$file>: $!";
 293             system "ls", "-l", $file;
 294         }
 295         else {
 296             my $line;
 297             while ($line = <F>) {
 298                 if ($line =~ /^=head1\s+NAME\b/) {
 299                     push @modpods, $file;
 300                     #warn "GOOD $file\n";
 301                     return;
 302                 }
 303             }
 304             warn "$0: $file: cannot find =head1 NAME\n";
 305         }
 306     }
 307 }
 308
 309 die "no pods" unless @modpods;
 310
 311 for (@modpods) {
 312     #($name) = /(\w+)\.p(m|od)$/;
 313     $name = path2modname($_);
 314     if ($name =~ /^[a-z]/) {
 315         push @pragmata, $_;
 316     } else {
 317         if ($done{$name}++) {
 318             # warn "already did $_\n";
 319             next;
 320         }
 321         push @modules, $_;
 322         push @modname, $name;
 323     }
 324 }
 325
 326 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
 327
 328
 329
 330         =head1 PRAGMA DOCUMENTATION
 331
 332 EOPOD2B
 333
 334 podset(sort @pragmata);
 335
 336 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
 337
 338
 339
 340         =head1 MODULE DOCUMENTATION
 341
 342 EOPOD2B
 343
 344 podset( @modules[ sort { $modname[$a] cmp $modname[$b] } 0 .. $#modules ] );
 345
 346 ($_= <<EOPOD2B) =~ s/^\t//gm;
 347
 348
 349         =head1 AUXILIARY DOCUMENTATION
 350
 351         Here should be listed all the extra programs' documentation, but they
 352         don't all have manual pages yet:
 353
 354         =over 4
 355
 356         =item a2p
 357
 358         =item s2p
 359
 360         =item find2perl
 361
 362         =item h2ph
 363
 364         =item c2ph
 365
 366         =item h2xs
 367
 368         =item xsubpp
 369
 370         =item pod2man
 371
 372         =item wrapsuid
 373
 374         =back
 375
 376         =head1 AUTHOR
 377
 378         Larry Wall <F<larry\@wall.org>>, with the help of oodles
 379         of other folks.
 380
 381
 382 EOPOD2B
 383 output $_;
 384 output "\n";                    # flush $LINE
 385 exit;
 386
 387 sub podset {
 388     local @ARGV = @_;
 389
 390     while(<>) {
 391         if (s/^=head1 (NAME)\s*/=head2 /) {
 392             $pod = path2modname($ARGV);
 393             unhead1();
 394             output "\n \n\n=head2 ";
 395             $_ = <>;
 396             if ( /^\s*$pod\b/ ) {
 397                 s/$pod\.pm/$pod/;       # '.pm' in NAME !?
 398                 output $_;
 399             } else {
 400                 s/^/$pod, /;
 401                 output $_;
 402             }
 403             next;
 404         }
 405         if (s/^=head1 (.*)/=item $1/) {
 406             unhead2();
 407             output "=over 4\n\n" unless $inhead1;
 408             $inhead1 = 1;
 409             output $_; nl(); next;
 410         }
 411         if (s/^=head2 (.*)/=item $1/) {
 412             unitem();
 413             output "=over 4\n\n" unless $inhead2;
 414             $inhead2 = 1;
 415             output $_; nl(); next;
 416         }
 417         if (s/^=item ([^=].*)/$1/) {
 418             next if $pod eq 'perldiag';
 419             s/^\s*\*\s*$// && next;
 420             s/^\s*\*\s*//;
 421             s/\n/ /g;
 422             s/\s+$//;
 423             next if /^[\d.]+$/;
 424             next if $pod eq 'perlmodlib' && /^ftp:/;
 425             ##print "=over 4\n\n" unless $initem;
 426             output ", " if $initem;
 427             $initem = 1;
 428             s/\.$//;
 429             s/^-X\b/-I<X>/;
 430             output $_; next;
 431         }
 432         if (s/^=cut\s*\n//) {
 433             unhead1();
 434             next;
 435         }
 436     }
 437 }
 438
 439 sub path2modname {
 440     local $_ = shift;
 441     s/\.p(m|od)$//;
 442     s-.*?/(lib|ext)/--;
 443     s-/-::-g;
 444     s/(\w+)::\1/$1/;
 445     return $_;
 446 }
 447
 448 sub unhead1 {
 449     unhead2();
 450     if ($inhead1) {
 451         output "\n\n=back\n\n";
 452     }
 453     $inhead1 = 0;
 454 }
 455
 456 sub unhead2 {
 457     unitem();
 458     if ($inhead2) {
 459         output "\n\n=back\n\n";
 460     }
 461     $inhead2 = 0;
 462 }
 463
 464 sub unitem {
 465     if ($initem) {
 466         output "\n\n";
 467         ##print "\n\n=back\n\n";
 468     }
 469     $initem = 0;
 470 }
 471
 472 sub nl {
 473     output "\n";
 474 }
 475
 476 my $NEWLINE;    # how many newlines have we seen recently
 477 my $LINE;       # what remains to be printed
 478
 479 sub output ($) {
 480     for (split /(\n)/, shift) {
 481         if ($_ eq "\n") {
 482             if ($LINE) {
 483                 print OUT wrap('', '', $LINE);
 484                 $LINE = '';
 485             }
 486             if ($NEWLINE < 2) {
 487                 print OUT;
 488                 $NEWLINE++;
 489             }
 490         }
 491         elsif (/\S/ && length) {
 492             $LINE .= $_;
 493             $NEWLINE = 0;
 494         }
 495     }
 496 }
 497
 498 !NO!SUBS!
 499
 500 close OUT or die "Can't close $file: $!";
 501 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 502 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
 503 chdir $origdir;