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