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