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