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