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