pod/buildtoc

   1 use File::Find;
   2 use Cwd;
   3 use Text::Wrap;
   4
   5 sub output ($);
   6
   7 @pods = qw(
   8            perl perlfaq perlfaq1 perlfaq2 perlfaq3 perlfaq4 perlfaq5
   9            perlfaq6 perlfaq7 perlfaq8 perlfaq9 perldelta perldata
  10            perlsyn perlop perlre perlrun perlfunc perlvar perlsub
  11            perlmod perlmodlib perlmodinstall perlfork perlform perllocale
  12            perlref perlreftut perldsc
  13            perllol perlboot perltoot perltootc perlobj perltie perlbot perlipc
  14            perldbmfilter perldebug perlnumber perldebguts
  15            perldiag perlsec perltrap perlport perlstyle perlpod perlbook
  16            perlembed perlapio perlxs perlxstut perlguts perlcall perlcompile
  17            perlapi perlintern perlhist
  18           );
  19
  20 for (@pods) { s/$/.pod/ }
  21
  22 $/ = '';
  23 @ARGV = @pods;
  24
  25 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
  26
  27         =head1 NAME
  28
  29         perltoc - perl documentation table of contents
  30
  31         =head1 DESCRIPTION
  32
  33         This page provides a brief table of contents for the rest of the Perl
  34         documentation set.  It is meant to be scanned quickly or grepped
  35         through to locate the proper section you're looking for.
  36
  37         =head1 BASIC DOCUMENTATION
  38
  39 EOPOD2B
  40 #' make emacs happy
  41
  42 podset(@pods);
  43
  44 find \&getpods => qw(../lib ../ext);
  45
  46 sub getpods {
  47     if (/\.p(od|m)$/) {
  48         # Skip .pm files that have corresponding .pod files, and Functions.pm.
  49         return if /(.*)\.pm$/ && -f "$1.pod";
  50         my $file = $File::Find::name;
  51         return if $file eq '../lib/Pod/Functions.pm'; # Used only by pod itself
  52
  53         die "tut $name" if $file =~ /TUT/;
  54         unless (open (F, "< $_\0")) {
  55             warn "bogus <$file>: $!";
  56             system "ls", "-l", $file;
  57         }
  58         else {
  59             my $line;
  60             while ($line = <F>) {
  61                 if ($line =~ /^=head1\s+NAME\b/) {
  62                     push @modpods, $file;
  63                     #warn "GOOD $file\n";
  64                     return;
  65                 }
  66             }
  67             warn "EVIL $file\n";
  68         }
  69     }
  70 }
  71
  72 die "no pods" unless @modpods;
  73
  74 for (@modpods) {
  75     #($name) = /(\w+)\.p(m|od)$/;
  76     $name = path2modname($_);
  77     if ($name =~ /^[a-z]/) {
  78         push @pragmata, $_;
  79     } else {
  80         if ($done{$name}++) {
  81             # warn "already did $_\n";
  82             next;
  83         }
  84         push @modules, $_;
  85         push @modname, $name;
  86     }
  87 }
  88
  89 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
  90
  91
  92
  93         =head1 PRAGMA DOCUMENTATION
  94
  95 EOPOD2B
  96
  97 podset(sort @pragmata);
  98
  99 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
 100
 101
 102
 103         =head1 MODULE DOCUMENTATION
 104
 105 EOPOD2B
 106
 107 podset( @modules[ sort { $modname[$a] cmp $modname[$b] } 0 .. $#modules ] );
 108
 109 ($_= <<EOPOD2B) =~ s/^\t//gm;
 110
 111
 112         =head1 AUXILIARY DOCUMENTATION
 113
 114         Here should be listed all the extra programs' documentation, but they
 115         don't all have manual pages yet:
 116
 117         =over
 118
 119         =item a2p
 120
 121         =item s2p
 122
 123         =item find2perl
 124
 125         =item h2ph
 126
 127         =item c2ph
 128
 129         =item h2xs
 130
 131         =item xsubpp
 132
 133         =item pod2man
 134
 135         =item wrapsuid
 136
 137         =back
 138
 139         =head1 AUTHOR
 140
 141         Larry Wall <F<larry\@wall.org>>, with the help of oodles
 142         of other folks.
 143
 144
 145 EOPOD2B
 146 output $_;
 147 output "\n";                    # flush $LINE
 148 exit;
 149
 150 sub podset {
 151     local @ARGV = @_;
 152
 153     while(<>) {
 154         if (s/^=head1 (NAME)\s*/=head2 /) {
 155             $pod = path2modname($ARGV);
 156             unhead1();
 157             output "\n \n\n=head2 ";
 158             $_ = <>;
 159             if ( /^\s*$pod\b/ ) {
 160                 s/$pod\.pm/$pod/;       # '.pm' in NAME !?
 161                 output $_;
 162             } else {
 163                 s/^/$pod, /;
 164                 output $_;
 165             }
 166             next;
 167         }
 168         if (s/^=head1 (.*)/=item $1/) {
 169             unhead2();
 170             output "=over\n\n" unless $inhead1;
 171             $inhead1 = 1;
 172             output $_; nl(); next;
 173         }
 174         if (s/^=head2 (.*)/=item $1/) {
 175             unitem();
 176             output "=over\n\n" unless $inhead2;
 177             $inhead2 = 1;
 178             output $_; nl(); next;
 179         }
 180         if (s/^=item ([^=].*)/$1/) {
 181             next if $pod eq 'perldiag';
 182             s/^\s*\*\s*$// && next;
 183             s/^\s*\*\s*//;
 184             s/\n/ /g;
 185             s/\s+$//;
 186             next if /^[\d.]+$/;
 187             next if $pod eq 'perlmodlib' && /^ftp:/;
 188             ##print "=over\n\n" unless $initem;
 189             output ", " if $initem;
 190             $initem = 1;
 191             s/\.$//;
 192             s/^-X\b/-I<X>/;
 193             output $_; next;
 194         }
 195         if (s/^=cut\s*\n//) {
 196             unhead1();
 197             next;
 198         }
 199     }
 200 }
 201
 202 sub path2modname {
 203     local $_ = shift;
 204     s/\.p(m|od)$//;
 205     s-.*?/(lib|ext)/--;
 206     s-/-::-g;
 207     s/(\w+)::\1/$1/;
 208     return $_;
 209 }
 210
 211 sub unhead1 {
 212     unhead2();
 213     if ($inhead1) {
 214         output "\n\n=back\n\n";
 215     }
 216     $inhead1 = 0;
 217 }
 218
 219 sub unhead2 {
 220     unitem();
 221     if ($inhead2) {
 222         output "\n\n=back\n\n";
 223     }
 224     $inhead2 = 0;
 225 }
 226
 227 sub unitem {
 228     if ($initem) {
 229         output "\n\n";
 230         ##print "\n\n=back\n\n";
 231     }
 232     $initem = 0;
 233 }
 234
 235 sub nl {
 236     output "\n";
 237 }
 238
 239 my $NEWLINE;    # how many newlines have we seen recently
 240 my $LINE;       # what remains to be printed
 241
 242 sub output ($) {
 243     for (split /(\n)/, shift) {
 244         if ($_ eq "\n") {
 245             if ($LINE) {
 246                 print wrap('', '', $LINE);
 247                 $LINE = '';
 248             }
 249             if ($NEWLINE < 2) {
 250                 print;
 251                 $NEWLINE++;
 252             }
 253         }
 254         elsif (/\S/ && length) {
 255             $LINE .= $_;
 256             $NEWLINE = 0;
 257         }
 258     }
 259 }