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