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