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 perltoot perltootc perlobj perltie perlbot perlipc
  14            perldbmfilter perldebug
  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 ([^=].*)\n/$1/) {
 181             next if $pod eq 'perldiag';
 182             s/^\s*\*\s*$// && next;
 183             s/^\s*\*\s*//;
 184             s/\s+$//;
 185             next if /^[\d.]+$/;
 186             next if $pod eq 'perlmodlib' && /^ftp:/;
 187             ##print "=over\n\n" unless $initem;
 188             output ", " if $initem;
 189             $initem = 1;
 190             s/\.$//;
 191             s/^-X\b/-I<X>/;
 192             output $_; next;
 193         }
 194         if (s/^=cut\s*\n//) {
 195             unhead1();
 196             next;
 197         }
 198     }
 199 }
 200
 201 sub path2modname {
 202     local $_ = shift;
 203     s/\.p(m|od)$//;
 204     s-.*?/(lib|ext)/--;
 205     s-/-::-g;
 206     s/(\w+)::\1/$1/;
 207     return $_;
 208 }
 209
 210 sub unhead1 {
 211     unhead2();
 212     if ($inhead1) {
 213         output "\n\n=back\n\n";
 214     }
 215     $inhead1 = 0;
 216 }
 217
 218 sub unhead2 {
 219     unitem();
 220     if ($inhead2) {
 221         output "\n\n=back\n\n";
 222     }
 223     $inhead2 = 0;
 224 }
 225
 226 sub unitem {
 227     if ($initem) {
 228         output "\n\n";
 229         ##print "\n\n=back\n\n";
 230     }
 231     $initem = 0;
 232 }
 233
 234 sub nl {
 235     output "\n";
 236 }
 237
 238 my $NEWLINE;    # how many newlines have we seen recently
 239 my $LINE;       # what remains to be printed
 240
 241 sub output ($) {
 242     for (split /(\n)/, shift) {
 243         if ($_ eq "\n") {
 244             if ($LINE) {
 245                 print wrap('', '', $LINE);
 246                 $LINE = '';
 247             }
 248             if ($NEWLINE < 2) {
 249                 print;
 250                 $NEWLINE++;
 251             }
 252         }
 253         elsif (/\S/ && length) {
 254             $LINE .= $_;
 255             $NEWLINE = 0;
 256         }
 257     }
 258 }