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