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     perlfreebsd
  74     perlhpux
  75     perlhurd
  76     perlirix
  77     perlmachten
  78     perlmacos
  79     perlmint
  80     perlmpeix
  81     perlnetware
  82     perlos2
  83     perlos390
  84     perlqnx
  85     perlplan9
  86     perlsolaris
  87     perltru64
  88     perluts
  89     perlvmesa
  90     perlvms
  91     perlvos
  92     perlwin32
  93           );
  94
  95 @CJKPODS = qw(
  96     perlcn
  97     perljp
  98     perlko
  99     perltw
 100           );
 101
 102 @pods =
 103   (
 104     qw(
 105
 106     perl
 107     perlintro
 108     perlfaq
 109     perltoc
 110     perlbook
 111
 112     perlsyn
 113     perldata
 114     perlop
 115     perlsub
 116     perlfunc
 117     perlreftut
 118     perldsc
 119     perlrequick
 120     perlpod
 121     perlpodspec
 122     perlstyle
 123     perltrap
 124
 125     perlrun
 126     perldiag
 127     perllexwarn
 128     perldebtut
 129     perldebug
 130
 131     perlvar
 132     perllol
 133     perlopentut
 134     perlpacktut
 135     perlretut
 136
 137     perlre
 138     perlref
 139
 140     perlform
 141
 142     perlboot
 143     perltoot
 144     perltooc
 145     perlobj
 146     perlbot
 147     perltie
 148
 149     perlipc
 150     perlfork
 151     perlnumber
 152
 153     perlthrtut
 154     perlothrtut
 155
 156     perlport
 157     perllocale
 158     perluniintro
 159     perlunicode
 160     perlebcdic
 161
 162     perlsec
 163
 164     perlmod
 165     perlmodinstall
 166     perlmodlib
 167     perlmodstyle
 168     perlnewmod
 169
 170     perlfaq1
 171     perlfaq2
 172     perlfaq3
 173     perlfaq4
 174     perlfaq5
 175     perlfaq6
 176     perlfaq7
 177     perlfaq8
 178     perlfaq9
 179
 180     perlcompile
 181
 182     perlembed
 183     perldebguts
 184     perlxstut
 185     perlxs
 186     perlclib
 187     perlguts
 188     perlcall
 189     perlutil
 190     perlfilter
 191     perldbmfilter
 192     perlapi
 193     perlintern
 194     perliol
 195     perlapio
 196     perltodo
 197     perlhack
 198
 199     perlhist
 200     perldelta
 201     perl572delta
 202     perl571delta
 203     perl570delta
 204     perl561delta
 205     perl56delta
 206     perl5005delta
 207     perl5004delta
 208
 209     ),
 210
 211     @ARCHPODS,
 212
 213   );
 214
 215 for (@ARCHPODS) { s/$/.pod/ }
 216 @ARCHPODS{@ARCHPODS} = ();
 217
 218 for (@CJKPODS) { s/$/.pod/ }
 219 @CJKPODS{@CJKPODS} = ();
 220
 221 for (@pods) { s/$/.pod/ }
 222 @pods{@pods} = ();
 223 @PODS{@PODS} = ();
 224
 225 open(MANI, "../MANIFEST") || die "$0: opening ../MANIFEST failed: $!";
 226 while (<MANI>) {
 227   if (m!^pod/([^.]+\.pod)\s+!i) {
 228      push @MANIPODS, $1;
 229   }
 230 }
 231 close(MANI);
 232 @MANIPODS{@MANIPODS} = ();
 233
 234 open(PERLPOD, "perl.pod") || die "$0: opening perl.pod failed: $!\n";
 235 while (<PERLPOD>) {
 236   if (/^For ease of access, /../^\(If you're intending /) {
 237         if (/^\s+(perl\S*)\s+\w/) {
 238                 push @PERLPODS, "$1.pod";
 239         }
 240   }
 241 }
 242 close(PERLPOD);
 243 die "$0: could not find the pod listing of perl.pod\n"
 244   unless @PERLPODS;
 245 @PERLPODS{@PERLPODS} = ();
 246
 247 # Delete the CJK because we cannot mix their encodings.
 248 delete @PERLPODS{@CJKPODS};
 249 delete @PODS{@CJKPODS};
 250 delete @pods{@CJKPODS};
 251
 252 # Cross-check against ourselves
 253 # Cross-check against the MANIFEST
 254 # Cross-check against the perl.pod
 255
 256 foreach my $i (sort keys %PODS) {
 257   warn "$0: $i exists but is unknown by buildtoc\n"
 258         unless exists $pods{$i};
 259   warn "$0: $i exists but is unknown by ../MANIFEST\n"
 260         if !exists $MANIPODS{$i} && !exists $ARCHPODS{$i} && !exists $CJKPODS{$i};
 261   warn "$0: $i exists but is unknown by perl.pod\n"
 262         unless exists $PERLPODS{$i};
 263 }
 264 foreach my $i (sort keys %pods) {
 265   warn "$0: $i is known by buildtoc but does not exist\n"
 266         unless exists $PODS{$i};
 267 }
 268 foreach my $i (sort keys %MANIPODS) {
 269   warn "$0: $i is known by ../MANIFEST but does not exist\n"
 270         unless exists $PODS{$i};
 271 }
 272 foreach my $i (sort keys %PERLPODS) {
 273   warn "$0: $i is known by perl.pod but does not exist\n"
 274         unless exists $PODS{$i};
 275 }
 276
 277 # We are ready to rock.
 278 open(OUT, ">perltoc.pod") || die "$0: creating perltoc.pod failed: $!";
 279
 280 $/ = '';
 281 @ARGV = @pods;
 282
 283 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
 284
 285         =head1 NAME
 286
 287         perltoc - perl documentation table of contents
 288
 289         =head1 DESCRIPTION
 290
 291         This page provides a brief table of contents for the rest of the Perl
 292         documentation set.  It is meant to be scanned quickly or grepped
 293         through to locate the proper section you're looking for.
 294
 295         =head1 BASIC DOCUMENTATION
 296
 297 EOPOD2B
 298 #' make emacs happy
 299
 300 podset(@pods);
 301
 302 find \&getpods => qw(../lib ../ext);
 303
 304 sub getpods {
 305     if (/\.p(od|m)$/) {
 306         my $file = $File::Find::name;
 307         return if $file eq '../lib/Pod/Functions.pm'; # Used only by pod itself
 308         return if $file =~ m!lib/Attribute/Handlers/demo/!;
 309         return if $file =~ m!lib/Net/FTP/.+\.pm!; # Hi, Graham! :-)
 310         return if $file =~ m!lib/Math/BigInt/t/!;
 311         return if $file =~ m!/Devel/PPPort/[Hh]arness|lib/Devel/Harness!i;
 312         return if $file =~ m!XS/(?:APItest|Typemap)!;
 313         die "tut $name" if $file =~ /TUT/;
 314         unless (open (F, "< $_\0")) {
 315             warn "bogus <$file>: $!";
 316             system "ls", "-l", $file;
 317         }
 318         else {
 319             my $line;
 320             while ($line = <F>) {
 321                 if ($line =~ /^=head1\s+NAME\b/) {
 322                     push @modpods, $file;
 323                     #warn "GOOD $file\n";
 324                     return;
 325                 }
 326             }
 327             warn "$0: $file: cannot find =head1 NAME\n";
 328         }
 329     }
 330 }
 331
 332 die "no pods" unless @modpods;
 333
 334 for (@modpods) {
 335     #($name) = /(\w+)\.p(m|od)$/;
 336     $name = path2modname($_);
 337     if ($name =~ /^[a-z]/) {
 338         push @pragmata, $_;
 339     } else {
 340         if ($done{$name}++) {
 341             # warn "already did $_\n";
 342             next;
 343         }
 344         push @modules, $_;
 345         push @modname, $name;
 346     }
 347 }
 348
 349 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
 350
 351
 352
 353         =head1 PRAGMA DOCUMENTATION
 354
 355 EOPOD2B
 356
 357 podset(sort @pragmata);
 358
 359 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
 360
 361
 362
 363         =head1 MODULE DOCUMENTATION
 364
 365 EOPOD2B
 366
 367 podset( @modules[ sort { $modname[$a] cmp $modname[$b] } 0 .. $#modules ] );
 368
 369 ($_= <<EOPOD2B) =~ s/^\t//gm;
 370
 371
 372         =head1 AUXILIARY DOCUMENTATION
 373
 374         Here should be listed all the extra programs' documentation, but they
 375         don't all have manual pages yet:
 376
 377         =over 4
 378
 379         =item a2p
 380
 381         =item s2p
 382
 383         =item find2perl
 384
 385         =item h2ph
 386
 387         =item c2ph
 388
 389         =item h2xs
 390
 391         =item xsubpp
 392
 393         =item pod2man
 394
 395         =item wrapsuid
 396
 397         =back
 398
 399         =head1 AUTHOR
 400
 401         Larry Wall <F<larry\@wall.org>>, with the help of oodles
 402         of other folks.
 403
 404
 405 EOPOD2B
 406 output $_;
 407 output "\n";                    # flush $LINE
 408 exit;
 409
 410 sub podset {
 411     local @ARGV = @_;
 412
 413     while(<>) {
 414         if (s/^=head1 (NAME)\s*/=head2 /) {
 415             $pod = path2modname($ARGV);
 416             unhead1();
 417             output "\n \n\n=head2 ";
 418             $_ = <>;
 419             if ( /^\s*$pod\b/ ) {
 420                 s/$pod\.pm/$pod/;       # '.pm' in NAME !?
 421                 output $_;
 422             } else {
 423                 s/^/$pod, /;
 424                 output $_;
 425             }
 426             next;
 427         }
 428         if (s/^=head1 (.*)/=item $1/) {
 429             unhead2();
 430             output "=over 4\n\n" unless $inhead1;
 431             $inhead1 = 1;
 432             output $_; nl(); next;
 433         }
 434         if (s/^=head2 (.*)/=item $1/) {
 435             unitem();
 436             output "=over 4\n\n" unless $inhead2;
 437             $inhead2 = 1;
 438             output $_; nl(); next;
 439         }
 440         if (s/^=item ([^=].*)/$1/) {
 441             next if $pod eq 'perldiag';
 442             s/^\s*\*\s*$// && next;
 443             s/^\s*\*\s*//;
 444             s/\n/ /g;
 445             s/\s+$//;
 446             next if /^[\d.]+$/;
 447             next if $pod eq 'perlmodlib' && /^ftp:/;
 448             ##print "=over 4\n\n" unless $initem;
 449             output ", " if $initem;
 450             $initem = 1;
 451             s/\.$//;
 452             s/^-X\b/-I<X>/;
 453             output $_; next;
 454         }
 455         if (s/^=cut\s*\n//) {
 456             unhead1();
 457             next;
 458         }
 459     }
 460 }
 461
 462 sub path2modname {
 463     local $_ = shift;
 464     s/\.p(m|od)$//;
 465     s-.*?/(lib|ext)/--;
 466     s-/-::-g;
 467     s/(\w+)::\1/$1/;
 468     return $_;
 469 }
 470
 471 sub unhead1 {
 472     unhead2();
 473     if ($inhead1) {
 474         output "\n\n=back\n\n";
 475     }
 476     $inhead1 = 0;
 477 }
 478
 479 sub unhead2 {
 480     unitem();
 481     if ($inhead2) {
 482         output "\n\n=back\n\n";
 483     }
 484     $inhead2 = 0;
 485 }
 486
 487 sub unitem {
 488     if ($initem) {
 489         output "\n\n";
 490         ##print "\n\n=back\n\n";
 491     }
 492     $initem = 0;
 493 }
 494
 495 sub nl {
 496     output "\n";
 497 }
 498
 499 my $NEWLINE;    # how many newlines have we seen recently
 500 my $LINE;       # what remains to be printed
 501
 502 sub output ($) {
 503     for (split /(\n)/, shift) {
 504         if ($_ eq "\n") {
 505             if ($LINE) {
 506                 print OUT wrap('', '', $LINE);
 507                 $LINE = '';
 508             }
 509             if ($NEWLINE < 2) {
 510                 print OUT;
 511                 $NEWLINE++;
 512             }
 513         }
 514         elsif (/\S/ && length) {
 515             $LINE .= $_;
 516             $NEWLINE = 0;
 517         }
 518     }
 519 }
 520
 521 !NO!SUBS!
 522
 523 close OUT or die "Can't close $file: $!";
 524 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 525 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
 526 chdir $origdir;