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