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