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