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