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     perlvmesa
 173     perlvms
 174     perlvos
 175     perlwin32
 176           );
 177
 178 @ARCHPODS = qw(
 179     perlaix
 180     perlamiga
 181     perlbs2000
 182     perlcygwin
 183     perldgux
 184     perldos
 185     perlepoc
 186     perlhpux
 187     perlmachten
 188     perlmacos
 189     perlmpeix
 190     perlos2
 191     perlos390
 192     perlsolaris
 193     perlvmesa
 194     perlvms
 195     perlvos
 196     perlwin32
 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
 286         die "tut $name" if $file =~ /TUT/;
 287         unless (open (F, "< $_\0")) {
 288             warn "bogus <$file>: $!";
 289             system "ls", "-l", $file;
 290         }
 291         else {
 292             my $line;
 293             while ($line = <F>) {
 294                 if ($line =~ /^=head1\s+NAME\b/) {
 295                     push @modpods, $file;
 296                     #warn "GOOD $file\n";
 297                     return;
 298                 }
 299             }
 300             warn "$0: $file: cannot find =head1 NAME\n";
 301         }
 302     }
 303 }
 304
 305 die "no pods" unless @modpods;
 306
 307 for (@modpods) {
 308     #($name) = /(\w+)\.p(m|od)$/;
 309     $name = path2modname($_);
 310     if ($name =~ /^[a-z]/) {
 311         push @pragmata, $_;
 312     } else {
 313         if ($done{$name}++) {
 314             # warn "already did $_\n";
 315             next;
 316         }
 317         push @modules, $_;
 318         push @modname, $name;
 319     }
 320 }
 321
 322 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
 323
 324
 325
 326         =head1 PRAGMA DOCUMENTATION
 327
 328 EOPOD2B
 329
 330 podset(sort @pragmata);
 331
 332 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
 333
 334
 335
 336         =head1 MODULE DOCUMENTATION
 337
 338 EOPOD2B
 339
 340 podset( @modules[ sort { $modname[$a] cmp $modname[$b] } 0 .. $#modules ] );
 341
 342 ($_= <<EOPOD2B) =~ s/^\t//gm;
 343
 344
 345         =head1 AUXILIARY DOCUMENTATION
 346
 347         Here should be listed all the extra programs' documentation, but they
 348         don't all have manual pages yet:
 349
 350         =over 4
 351
 352         =item a2p
 353
 354         =item s2p
 355
 356         =item find2perl
 357
 358         =item h2ph
 359
 360         =item c2ph
 361
 362         =item h2xs
 363
 364         =item xsubpp
 365
 366         =item pod2man
 367
 368         =item wrapsuid
 369
 370         =back
 371
 372         =head1 AUTHOR
 373
 374         Larry Wall <F<larry\@wall.org>>, with the help of oodles
 375         of other folks.
 376
 377
 378 EOPOD2B
 379 output $_;
 380 output "\n";                    # flush $LINE
 381 exit;
 382
 383 sub podset {
 384     local @ARGV = @_;
 385
 386     while(<>) {
 387         if (s/^=head1 (NAME)\s*/=head2 /) {
 388             $pod = path2modname($ARGV);
 389             unhead1();
 390             output "\n \n\n=head2 ";
 391             $_ = <>;
 392             if ( /^\s*$pod\b/ ) {
 393                 s/$pod\.pm/$pod/;       # '.pm' in NAME !?
 394                 output $_;
 395             } else {
 396                 s/^/$pod, /;
 397                 output $_;
 398             }
 399             next;
 400         }
 401         if (s/^=head1 (.*)/=item $1/) {
 402             unhead2();
 403             output "=over 4\n\n" unless $inhead1;
 404             $inhead1 = 1;
 405             output $_; nl(); next;
 406         }
 407         if (s/^=head2 (.*)/=item $1/) {
 408             unitem();
 409             output "=over 4\n\n" unless $inhead2;
 410             $inhead2 = 1;
 411             output $_; nl(); next;
 412         }
 413         if (s/^=item ([^=].*)/$1/) {
 414             next if $pod eq 'perldiag';
 415             s/^\s*\*\s*$// && next;
 416             s/^\s*\*\s*//;
 417             s/\n/ /g;
 418             s/\s+$//;
 419             next if /^[\d.]+$/;
 420             next if $pod eq 'perlmodlib' && /^ftp:/;
 421             ##print "=over 4\n\n" unless $initem;
 422             output ", " if $initem;
 423             $initem = 1;
 424             s/\.$//;
 425             s/^-X\b/-I<X>/;
 426             output $_; next;
 427         }
 428         if (s/^=cut\s*\n//) {
 429             unhead1();
 430             next;
 431         }
 432     }
 433 }
 434
 435 sub path2modname {
 436     local $_ = shift;
 437     s/\.p(m|od)$//;
 438     s-.*?/(lib|ext)/--;
 439     s-/-::-g;
 440     s/(\w+)::\1/$1/;
 441     return $_;
 442 }
 443
 444 sub unhead1 {
 445     unhead2();
 446     if ($inhead1) {
 447         output "\n\n=back\n\n";
 448     }
 449     $inhead1 = 0;
 450 }
 451
 452 sub unhead2 {
 453     unitem();
 454     if ($inhead2) {
 455         output "\n\n=back\n\n";
 456     }
 457     $inhead2 = 0;
 458 }
 459
 460 sub unitem {
 461     if ($initem) {
 462         output "\n\n";
 463         ##print "\n\n=back\n\n";
 464     }
 465     $initem = 0;
 466 }
 467
 468 sub nl {
 469     output "\n";
 470 }
 471
 472 my $NEWLINE;    # how many newlines have we seen recently
 473 my $LINE;       # what remains to be printed
 474
 475 sub output ($) {
 476     for (split /(\n)/, shift) {
 477         if ($_ eq "\n") {
 478             if ($LINE) {
 479                 print OUT wrap('', '', $LINE);
 480                 $LINE = '';
 481             }
 482             if ($NEWLINE < 2) {
 483                 print OUT;
 484                 $NEWLINE++;
 485             }
 486         }
 487         elsif (/\S/ && length) {
 488             $LINE .= $_;
 489             $NEWLINE = 0;
 490         }
 491     }
 492 }
 493
 494 !NO!SUBS!
 495
 496 close OUT or die "Can't close $file: $!";
 497 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 498 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
 499 chdir $origdir;