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         die "tut $name" if $file =~ /TUT/;
 313         unless (open (F, "< $_\0")) {
 314             warn "bogus <$file>: $!";
 315             system "ls", "-l", $file;
 316         }
 317         else {
 318             my $line;
 319             while ($line = <F>) {
 320                 if ($line =~ /^=head1\s+NAME\b/) {
 321                     push @modpods, $file;
 322                     #warn "GOOD $file\n";
 323                     return;
 324                 }
 325             }
 326             warn "$0: $file: cannot find =head1 NAME\n";
 327         }
 328     }
 329 }
 330
 331 die "no pods" unless @modpods;
 332
 333 for (@modpods) {
 334     #($name) = /(\w+)\.p(m|od)$/;
 335     $name = path2modname($_);
 336     if ($name =~ /^[a-z]/) {
 337         push @pragmata, $_;
 338     } else {
 339         if ($done{$name}++) {
 340             # warn "already did $_\n";
 341             next;
 342         }
 343         push @modules, $_;
 344         push @modname, $name;
 345     }
 346 }
 347
 348 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
 349
 350
 351
 352         =head1 PRAGMA DOCUMENTATION
 353
 354 EOPOD2B
 355
 356 podset(sort @pragmata);
 357
 358 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
 359
 360
 361
 362         =head1 MODULE DOCUMENTATION
 363
 364 EOPOD2B
 365
 366 podset( @modules[ sort { $modname[$a] cmp $modname[$b] } 0 .. $#modules ] );
 367
 368 ($_= <<EOPOD2B) =~ s/^\t//gm;
 369
 370
 371         =head1 AUXILIARY DOCUMENTATION
 372
 373         Here should be listed all the extra programs' documentation, but they
 374         don't all have manual pages yet:
 375
 376         =over 4
 377
 378         =item a2p
 379
 380         =item s2p
 381
 382         =item find2perl
 383
 384         =item h2ph
 385
 386         =item c2ph
 387
 388         =item h2xs
 389
 390         =item xsubpp
 391
 392         =item pod2man
 393
 394         =item wrapsuid
 395
 396         =back
 397
 398         =head1 AUTHOR
 399
 400         Larry Wall <F<larry\@wall.org>>, with the help of oodles
 401         of other folks.
 402
 403
 404 EOPOD2B
 405 output $_;
 406 output "\n";                    # flush $LINE
 407 exit;
 408
 409 sub podset {
 410     local @ARGV = @_;
 411
 412     while(<>) {
 413         if (s/^=head1 (NAME)\s*/=head2 /) {
 414             $pod = path2modname($ARGV);
 415             unhead1();
 416             output "\n \n\n=head2 ";
 417             $_ = <>;
 418             if ( /^\s*$pod\b/ ) {
 419                 s/$pod\.pm/$pod/;       # '.pm' in NAME !?
 420                 output $_;
 421             } else {
 422                 s/^/$pod, /;
 423                 output $_;
 424             }
 425             next;
 426         }
 427         if (s/^=head1 (.*)/=item $1/) {
 428             unhead2();
 429             output "=over 4\n\n" unless $inhead1;
 430             $inhead1 = 1;
 431             output $_; nl(); next;
 432         }
 433         if (s/^=head2 (.*)/=item $1/) {
 434             unitem();
 435             output "=over 4\n\n" unless $inhead2;
 436             $inhead2 = 1;
 437             output $_; nl(); next;
 438         }
 439         if (s/^=item ([^=].*)/$1/) {
 440             next if $pod eq 'perldiag';
 441             s/^\s*\*\s*$// && next;
 442             s/^\s*\*\s*//;
 443             s/\n/ /g;
 444             s/\s+$//;
 445             next if /^[\d.]+$/;
 446             next if $pod eq 'perlmodlib' && /^ftp:/;
 447             ##print "=over 4\n\n" unless $initem;
 448             output ", " if $initem;
 449             $initem = 1;
 450             s/\.$//;
 451             s/^-X\b/-I<X>/;
 452             output $_; next;
 453         }
 454         if (s/^=cut\s*\n//) {
 455             unhead1();
 456             next;
 457         }
 458     }
 459 }
 460
 461 sub path2modname {
 462     local $_ = shift;
 463     s/\.p(m|od)$//;
 464     s-.*?/(lib|ext)/--;
 465     s-/-::-g;
 466     s/(\w+)::\1/$1/;
 467     return $_;
 468 }
 469
 470 sub unhead1 {
 471     unhead2();
 472     if ($inhead1) {
 473         output "\n\n=back\n\n";
 474     }
 475     $inhead1 = 0;
 476 }
 477
 478 sub unhead2 {
 479     unitem();
 480     if ($inhead2) {
 481         output "\n\n=back\n\n";
 482     }
 483     $inhead2 = 0;
 484 }
 485
 486 sub unitem {
 487     if ($initem) {
 488         output "\n\n";
 489         ##print "\n\n=back\n\n";
 490     }
 491     $initem = 0;
 492 }
 493
 494 sub nl {
 495     output "\n";
 496 }
 497
 498 my $NEWLINE;    # how many newlines have we seen recently
 499 my $LINE;       # what remains to be printed
 500
 501 sub output ($) {
 502     for (split /(\n)/, shift) {
 503         if ($_ eq "\n") {
 504             if ($LINE) {
 505                 print OUT wrap('', '', $LINE);
 506                 $LINE = '';
 507             }
 508             if ($NEWLINE < 2) {
 509                 print OUT;
 510                 $NEWLINE++;
 511             }
 512         }
 513         elsif (/\S/ && length) {
 514             $LINE .= $_;
 515             $NEWLINE = 0;
 516         }
 517     }
 518 }
 519
 520 !NO!SUBS!
 521
 522 close OUT or die "Can't close $file: $!";
 523 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 524 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
 525 chdir $origdir;