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