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