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