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