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