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