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