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