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