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