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