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