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