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 # Build perltoc.pod and sanity check the list of pods against all
  43 # of the MANIFEST, perl.pod, and ourselves.
  44 #
  45
  46 use File::Find;
  47 use Cwd;
  48 use Text::Wrap;
  49
  50 @PODS = glob("*.pod");
  51
  52 sub output ($);
  53
  54 if (-d "pod") {
  55   die "$0: failed to chdir('pod'): $!\n" unless chdir("pod");
  56 }
  57
  58 @pods = qw(
  59            perl perlfaq perlfaq1 perlfaq2 perlfaq3 perlfaq4 perlfaq5
  60            perlfaq6 perlfaq7 perlfaq8 perlfaq9 perldelta perldata
  61            perlsyn perlop perlre perlrun perlfunc perlvar perlsub
  62            perlmod perlmodlib perlmodinstall perlfork perlform perllocale
  63            perlref perlreftut perldsc
  64            perllol perlboot perltoot perltootc perlobj perltie perlbot perlipc
  65            perldbmfilter perldebug perlnumber perldebguts
  66            perldiag perlsec perltrap perlport perlstyle perlpod perlbook
  67            perlembed perlapio perlxs perlxstut perlguts perlcall perlcompile
  68            perlapi perlintern perlhist
  69           );
  70
  71 for (@pods) { s/$/.pod/ }
  72 @pods{@pods} = ();
  73 @PODS{@PODS} = ();
  74
  75 open(MANI, "../MANIFEST") || die "$0: opening ../MANIFEST failed: $!";
  76 while (<MANI>) {
  77   if (m!^pod/([^.]+\.pod)\s+!i) {
  78      push @MANIPODS, $1;
  79   }
  80 }
  81 close(MANI);
  82 @MANIPODS{@MANIPODS} = ();
  83
  84 open(PERLPOD, "perl.pod") || die "$0: opening perl.pod failed: $!\n";
  85 while (<PERLPOD>) {
  86   if (/^For ease of access, /../^\(If you're intending /) {
  87         if (/^\s+(perl\w+)\s+Perl /) {
  88                 push @PERLPODS, "$1.pod";
  89         }
  90   }
  91 }
  92 close(PERLPOD);
  93 die "$0: could not find the pod listing of perl.pod\n"
  94   unless @PERLPODS;
  95 @PERLPODS{@PERLPODS} = ();
  96
  97 # Cross-check against ourselves
  98 # Cross-check against the MANIFEST
  99 # Cross-check against the perl.pod
 100
 101 foreach my $i (sort keys %PODS) {
 102   warn "$0: $i exists but is unknown by buildtoc\n"
 103         unless exists $pods{$i};
 104   warn "$0: $i exists but is unknown by ../MANIFEST\n"
 105         unless exists $MANIPODS{$i};
 106   warn "$0: $i exists but is unknown by perl.pod\n"
 107         unless exists $PERLPODS{$i};
 108 }
 109 foreach my $i (sort keys %pods) {
 110   warn "$0: $i is known by buildtoc but does not exist\n"
 111         unless exists $PODS{$i};
 112 }
 113 foreach my $i (sort keys %MANIPODS) {
 114   warn "$0: $i is known by ../MANIFEST but does not exist\n"
 115         unless exists $PODS{$i};
 116 }
 117 foreach my $i (sort keys %PERLPODS) {
 118   warn "$0: $i is known by perl.pod but does not exist\n"
 119         unless exists $PODS{$i};
 120 }
 121
 122 # We are ready to rock.
 123 open(OUT, ">perltoc.pod") || die "$0: creating perltoc.pod failed: $!";
 124
 125 $/ = '';
 126 @ARGV = @pods;
 127
 128 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
 129
 130         =head1 NAME
 131
 132         perltoc - perl documentation table of contents
 133
 134         =head1 DESCRIPTION
 135
 136         This page provides a brief table of contents for the rest of the Perl
 137         documentation set.  It is meant to be scanned quickly or grepped
 138         through to locate the proper section you're looking for.
 139
 140         =head1 BASIC DOCUMENTATION
 141
 142 EOPOD2B
 143 #' make emacs happy
 144
 145 podset(@pods);
 146
 147 find \&getpods => qw(../lib ../ext);
 148
 149 sub getpods {
 150     if (/\.p(od|m)$/) {
 151         # Skip .pm files that have corresponding .pod files, and Functions.pm.
 152         return if /(.*)\.pm$/ && -f "$1.pod";
 153         my $file = $File::Find::name;
 154         return if $file eq '../lib/Pod/Functions.pm'; # Used only by pod itself
 155
 156         die "tut $name" if $file =~ /TUT/;
 157         unless (open (F, "< $_\0")) {
 158             warn "bogus <$file>: $!";
 159             system "ls", "-l", $file;
 160         }
 161         else {
 162             my $line;
 163             while ($line = <F>) {
 164                 if ($line =~ /^=head1\s+NAME\b/) {
 165                     push @modpods, $file;
 166                     #warn "GOOD $file\n";
 167                     return;
 168                 }
 169             }
 170             warn "$0: $file: cannot find =head1 NAME\n";
 171         }
 172     }
 173 }
 174
 175 die "no pods" unless @modpods;
 176
 177 for (@modpods) {
 178     #($name) = /(\w+)\.p(m|od)$/;
 179     $name = path2modname($_);
 180     if ($name =~ /^[a-z]/) {
 181         push @pragmata, $_;
 182     } else {
 183         if ($done{$name}++) {
 184             # warn "already did $_\n";
 185             next;
 186         }
 187         push @modules, $_;
 188         push @modname, $name;
 189     }
 190 }
 191
 192 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
 193
 194
 195
 196         =head1 PRAGMA DOCUMENTATION
 197
 198 EOPOD2B
 199
 200 podset(sort @pragmata);
 201
 202 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
 203
 204
 205
 206         =head1 MODULE DOCUMENTATION
 207
 208 EOPOD2B
 209
 210 podset( @modules[ sort { $modname[$a] cmp $modname[$b] } 0 .. $#modules ] );
 211
 212 ($_= <<EOPOD2B) =~ s/^\t//gm;
 213
 214
 215         =head1 AUXILIARY DOCUMENTATION
 216
 217         Here should be listed all the extra programs' documentation, but they
 218         don't all have manual pages yet:
 219
 220         =over
 221
 222         =item a2p
 223
 224         =item s2p
 225
 226         =item find2perl
 227
 228         =item h2ph
 229
 230         =item c2ph
 231
 232         =item h2xs
 233
 234         =item xsubpp
 235
 236         =item pod2man
 237
 238         =item wrapsuid
 239
 240         =back
 241
 242         =head1 AUTHOR
 243
 244         Larry Wall <F<larry\@wall.org>>, with the help of oodles
 245         of other folks.
 246
 247
 248 EOPOD2B
 249 output $_;
 250 output "\n";                    # flush $LINE
 251 exit;
 252
 253 sub podset {
 254     local @ARGV = @_;
 255
 256     while(<>) {
 257         if (s/^=head1 (NAME)\s*/=head2 /) {
 258             $pod = path2modname($ARGV);
 259             unhead1();
 260             output "\n \n\n=head2 ";
 261             $_ = <>;
 262             if ( /^\s*$pod\b/ ) {
 263                 s/$pod\.pm/$pod/;       # '.pm' in NAME !?
 264                 output $_;
 265             } else {
 266                 s/^/$pod, /;
 267                 output $_;
 268             }
 269             next;
 270         }
 271         if (s/^=head1 (.*)/=item $1/) {
 272             unhead2();
 273             output "=over\n\n" unless $inhead1;
 274             $inhead1 = 1;
 275             output $_; nl(); next;
 276         }
 277         if (s/^=head2 (.*)/=item $1/) {
 278             unitem();
 279             output "=over\n\n" unless $inhead2;
 280             $inhead2 = 1;
 281             output $_; nl(); next;
 282         }
 283         if (s/^=item ([^=].*)/$1/) {
 284             next if $pod eq 'perldiag';
 285             s/^\s*\*\s*$// && next;
 286             s/^\s*\*\s*//;
 287             s/\n/ /g;
 288             s/\s+$//;
 289             next if /^[\d.]+$/;
 290             next if $pod eq 'perlmodlib' && /^ftp:/;
 291             ##print "=over\n\n" unless $initem;
 292             output ", " if $initem;
 293             $initem = 1;
 294             s/\.$//;
 295             s/^-X\b/-I<X>/;
 296             output $_; next;
 297         }
 298         if (s/^=cut\s*\n//) {
 299             unhead1();
 300             next;
 301         }
 302     }
 303 }
 304
 305 sub path2modname {
 306     local $_ = shift;
 307     s/\.p(m|od)$//;
 308     s-.*?/(lib|ext)/--;
 309     s-/-::-g;
 310     s/(\w+)::\1/$1/;
 311     return $_;
 312 }
 313
 314 sub unhead1 {
 315     unhead2();
 316     if ($inhead1) {
 317         output "\n\n=back\n\n";
 318     }
 319     $inhead1 = 0;
 320 }
 321
 322 sub unhead2 {
 323     unitem();
 324     if ($inhead2) {
 325         output "\n\n=back\n\n";
 326     }
 327     $inhead2 = 0;
 328 }
 329
 330 sub unitem {
 331     if ($initem) {
 332         output "\n\n";
 333         ##print "\n\n=back\n\n";
 334     }
 335     $initem = 0;
 336 }
 337
 338 sub nl {
 339     output "\n";
 340 }
 341
 342 my $NEWLINE;    # how many newlines have we seen recently
 343 my $LINE;       # what remains to be printed
 344
 345 sub output ($) {
 346     for (split /(\n)/, shift) {
 347         if ($_ eq "\n") {
 348             if ($LINE) {
 349                 print OUT wrap('', '', $LINE);
 350                 $LINE = '';
 351             }
 352             if ($NEWLINE < 2) {
 353                 print OUT;
 354                 $NEWLINE++;
 355             }
 356         }
 357         elsif (/\S/ && length) {
 358             $LINE .= $_;
 359             $NEWLINE = 0;
 360         }
 361     }
 362 }
 363
 364 !NO!SUBS!
 365