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