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