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
 292         die "tut $name" if $file =~ /TUT/;
 293         unless (open (F, "< $_\0")) {
 294             warn "bogus <$file>: $!";
 295             system "ls", "-l", $file;
 296         }
 297         else {
 298             my $line;
 299             while ($line = <F>) {
 300                 if ($line =~ /^=head1\s+NAME\b/) {
 301                     push @modpods, $file;
 302                     #warn "GOOD $file\n";
 303                     return;
 304                 }
 305             }
 306             warn "$0: $file: cannot find =head1 NAME\n";
 307         }
 308     }
 309 }
 310
 311 die "no pods" unless @modpods;
 312
 313 for (@modpods) {
 314     #($name) = /(\w+)\.p(m|od)$/;
 315     $name = path2modname($_);
 316     if ($name =~ /^[a-z]/) {
 317         push @pragmata, $_;
 318     } else {
 319         if ($done{$name}++) {
 320             # warn "already did $_\n";
 321             next;
 322         }
 323         push @modules, $_;
 324         push @modname, $name;
 325     }
 326 }
 327
 328 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
 329
 330
 331
 332         =head1 PRAGMA DOCUMENTATION
 333
 334 EOPOD2B
 335
 336 podset(sort @pragmata);
 337
 338 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
 339
 340
 341
 342         =head1 MODULE DOCUMENTATION
 343
 344 EOPOD2B
 345
 346 podset( @modules[ sort { $modname[$a] cmp $modname[$b] } 0 .. $#modules ] );
 347
 348 ($_= <<EOPOD2B) =~ s/^\t//gm;
 349
 350
 351         =head1 AUXILIARY DOCUMENTATION
 352
 353         Here should be listed all the extra programs' documentation, but they
 354         don't all have manual pages yet:
 355
 356         =over 4
 357
 358         =item a2p
 359
 360         =item s2p
 361
 362         =item find2perl
 363
 364         =item h2ph
 365
 366         =item c2ph
 367
 368         =item h2xs
 369
 370         =item xsubpp
 371
 372         =item pod2man
 373
 374         =item wrapsuid
 375
 376         =back
 377
 378         =head1 AUTHOR
 379
 380         Larry Wall <F<larry\@wall.org>>, with the help of oodles
 381         of other folks.
 382
 383
 384 EOPOD2B
 385 output $_;
 386 output "\n";                    # flush $LINE
 387 exit;
 388
 389 sub podset {
 390     local @ARGV = @_;
 391
 392     while(<>) {
 393         if (s/^=head1 (NAME)\s*/=head2 /) {
 394             $pod = path2modname($ARGV);
 395             unhead1();
 396             output "\n \n\n=head2 ";
 397             $_ = <>;
 398             if ( /^\s*$pod\b/ ) {
 399                 s/$pod\.pm/$pod/;       # '.pm' in NAME !?
 400                 output $_;
 401             } else {
 402                 s/^/$pod, /;
 403                 output $_;
 404             }
 405             next;
 406         }
 407         if (s/^=head1 (.*)/=item $1/) {
 408             unhead2();
 409             output "=over 4\n\n" unless $inhead1;
 410             $inhead1 = 1;
 411             output $_; nl(); next;
 412         }
 413         if (s/^=head2 (.*)/=item $1/) {
 414             unitem();
 415             output "=over 4\n\n" unless $inhead2;
 416             $inhead2 = 1;
 417             output $_; nl(); next;
 418         }
 419         if (s/^=item ([^=].*)/$1/) {
 420             next if $pod eq 'perldiag';
 421             s/^\s*\*\s*$// && next;
 422             s/^\s*\*\s*//;
 423             s/\n/ /g;
 424             s/\s+$//;
 425             next if /^[\d.]+$/;
 426             next if $pod eq 'perlmodlib' && /^ftp:/;
 427             ##print "=over 4\n\n" unless $initem;
 428             output ", " if $initem;
 429             $initem = 1;
 430             s/\.$//;
 431             s/^-X\b/-I<X>/;
 432             output $_; next;
 433         }
 434         if (s/^=cut\s*\n//) {
 435             unhead1();
 436             next;
 437         }
 438     }
 439 }
 440
 441 sub path2modname {
 442     local $_ = shift;
 443     s/\.p(m|od)$//;
 444     s-.*?/(lib|ext)/--;
 445     s-/-::-g;
 446     s/(\w+)::\1/$1/;
 447     return $_;
 448 }
 449
 450 sub unhead1 {
 451     unhead2();
 452     if ($inhead1) {
 453         output "\n\n=back\n\n";
 454     }
 455     $inhead1 = 0;
 456 }
 457
 458 sub unhead2 {
 459     unitem();
 460     if ($inhead2) {
 461         output "\n\n=back\n\n";
 462     }
 463     $inhead2 = 0;
 464 }
 465
 466 sub unitem {
 467     if ($initem) {
 468         output "\n\n";
 469         ##print "\n\n=back\n\n";
 470     }
 471     $initem = 0;
 472 }
 473
 474 sub nl {
 475     output "\n";
 476 }
 477
 478 my $NEWLINE;    # how many newlines have we seen recently
 479 my $LINE;       # what remains to be printed
 480
 481 sub output ($) {
 482     for (split /(\n)/, shift) {
 483         if ($_ eq "\n") {
 484             if ($LINE) {
 485                 print OUT wrap('', '', $LINE);
 486                 $LINE = '';
 487             }
 488             if ($NEWLINE < 2) {
 489                 print OUT;
 490                 $NEWLINE++;
 491             }
 492         }
 493         elsif (/\S/ && length) {
 494             $LINE .= $_;
 495             $NEWLINE = 0;
 496         }
 497     }
 498 }
 499
 500 !NO!SUBS!
 501
 502 close OUT or die "Can't close $file: $!";
 503 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 504 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
 505 chdir $origdir;