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