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