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