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