autodoc.pl

   1 #!/usr/bin/perl -w
   2
   3 require 5.003;  # keep this compatible, an old perl is all we may have before
   4                 # we build the new one
   5
   6 BEGIN {
   7   push @INC, 'lib';
   8   require 'regen_lib.pl';
   9 }
  10
  11
  12 #
  13 # See database of global and static function prototypes in embed.fnc
  14 # This is used to generate prototype headers under various configurations,
  15 # export symbols lists for different platforms, and macros to provide an
  16 # implicit interpreter context argument.
  17 #
  18
  19 open IN, "embed.fnc" or die $!;
  20
  21 # walk table providing an array of components in each line to
  22 # subroutine, printing the result
  23 sub walk_table (&@) {
  24     my $function = shift;
  25     my $filename = shift || '-';
  26     my $leader = shift;
  27     my $trailer = shift;
  28     my $F;
  29     local *F;
  30     if (ref $filename) {        # filehandle
  31         $F = $filename;
  32     }
  33     else {
  34         safer_unlink $filename;
  35         open F, ">$filename" or die "Can't open $filename: $!";
  36         binmode F;
  37         $F = \*F;
  38     }
  39     print $F $leader if $leader;
  40     seek IN, 0, 0;              # so we may restart
  41     while (<IN>) {
  42         chomp;
  43         next if /^:/;
  44         while (s|\\\s*$||) {
  45             $_ .= <IN>;
  46             chomp;
  47         }
  48         s/\s+$//;
  49         my @args;
  50         if (/^\s*(#|$)/) {
  51             @args = $_;
  52         }
  53         else {
  54             @args = split /\s*\|\s*/, $_;
  55         }
  56         s/\b(NN|NULLOK)\b\s+//g for @args;
  57         print $F $function->(@args);
  58     }
  59     print $F $trailer if $trailer;
  60     unless (ref $filename) {
  61         close $F or die "Error closing $filename: $!";
  62     }
  63 }
  64
  65 my %apidocs;
  66 my %gutsdocs;
  67 my %docfuncs;
  68 my %seenfuncs;
  69
  70 my $curheader = "Unknown section";
  71
  72 sub autodoc ($$) { # parse a file and extract documentation info
  73     my($fh,$file) = @_;
  74     my($in, $doc, $line);
  75 FUNC:
  76     while (defined($in = <$fh>)) {
  77         if ($in=~ /^=head1 (.*)/) {
  78             $curheader = $1;
  79             next FUNC;
  80         }
  81         $line++;
  82         if ($in =~ /^=for\s+apidoc\s+(.*?)\s*\n/) {
  83             my $proto = $1;
  84             $proto = "||$proto" unless $proto =~ /\|/;
  85             my($flags, $ret, $name, @args) = split /\|/, $proto;
  86             my $docs = "";
  87 DOC:
  88             while (defined($doc = <$fh>)) {
  89                 $line++;
  90                 last DOC if $doc =~ /^=\w+/;
  91                 if ($doc =~ m:^\*/$:) {
  92                     warn "=cut missing? $file:$line:$doc";;
  93                     last DOC;
  94                 }
  95                 $docs .= $doc;
  96             }
  97             $docs = "\n$docs" if $docs and $docs !~ /^\n/;
  98             if ($flags =~ /m/) {
  99                 if ($flags =~ /A/) {
 100                     $apidocs{$curheader}{$name} = [$flags, $docs, $ret, $file, @args];
 101                 }
 102                 else {
 103                     $gutsdocs{$curheader}{$name} = [$flags, $docs, $ret, $file, @args];
 104                 }
 105             }
 106             else {
 107                 $docfuncs{$name} = [$flags, $docs, $ret, $file, $curheader, @args];
 108             }
 109             if (defined $doc) {
 110                 if ($doc =~ /^=(?:for|head)/) {
 111                     $in = $doc;
 112                     redo FUNC;
 113                 }
 114             } else {
 115                 warn "$file:$line:$in";
 116             }
 117         }
 118     }
 119 }
 120
 121 sub docout ($$$) { # output the docs for one function
 122     my($fh, $name, $docref) = @_;
 123     my($flags, $docs, $ret, $file, @args) = @$docref;
 124     $name =~ s/\s*$//;
 125
 126     $docs .= "NOTE: this function is experimental and may change or be
 127 removed without notice.\n\n" if $flags =~ /x/;
 128     $docs .= "NOTE: the perl_ form of this function is deprecated.\n\n"
 129         if $flags =~ /p/;
 130
 131     print $fh "=item $name\nX<$name>\n$docs";
 132
 133     if ($flags =~ /U/) { # no usage
 134         # nothing
 135     } elsif ($flags =~ /s/) { # semicolon ("dTHR;")
 136         print $fh "\t\t$name;\n\n";
 137     } elsif ($flags =~ /n/) { # no args
 138         print $fh "\t$ret\t$name\n\n";
 139     } else { # full usage
 140         print $fh "\t$ret\t$name";
 141         print $fh "(" . join(", ", @args) . ")";
 142         print $fh "\n\n";
 143     }
 144     print $fh "=for hackers\nFound in file $file\n\n";
 145 }
 146
 147 my $file;
 148 # glob() picks up docs from extra .c or .h files that may be in unclean
 149 # development trees.
 150 my $MANIFEST = do {
 151   local ($/, *FH);
 152   open FH, "MANIFEST" or die "Can't open MANIFEST: $!";
 153   <FH>;
 154 };
 155
 156 for $file (($MANIFEST =~ /^(\S+\.c)\t/gm), ($MANIFEST =~ /^(\S+\.h)\t/gm)) {
 157     open F, "< $file" or die "Cannot open $file for docs: $!\n";
 158     $curheader = "Functions in file $file\n";
 159     autodoc(\*F,$file);
 160     close F or die "Error closing $file: $!\n";
 161 }
 162
 163 safer_unlink "pod/perlapi.pod";
 164 open (DOC, ">pod/perlapi.pod") or
 165         die "Can't create pod/perlapi.pod: $!\n";
 166 binmode DOC;
 167
 168 walk_table {    # load documented functions into appropriate hash
 169     if (@_ > 1) {
 170         my($flags, $retval, $func, @args) = @_;
 171         return "" unless $flags =~ /d/;
 172         $func =~ s/\t//g; $flags =~ s/p//; # clean up fields from embed.pl
 173         $retval =~ s/\t//;
 174         my $docref = delete $docfuncs{$func};
 175         $seenfuncs{$func} = 1;
 176         if ($docref and @$docref) {
 177             if ($flags =~ /A/) {
 178                 $docref->[0].="x" if $flags =~ /M/;
 179                 $apidocs{$docref->[4]}{$func} =
 180                     [$docref->[0] . 'A', $docref->[1], $retval, $docref->[3],
 181                         @args];
 182             } else {
 183                 $gutsdocs{$docref->[4]}{$func} =
 184                     [$docref->[0], $docref->[1], $retval, $docref->[3], @args];
 185             }
 186         }
 187         else {
 188             warn "no docs for $func\n" unless $seenfuncs{$func};
 189         }
 190     }
 191     return "";
 192 } \*DOC;
 193
 194 for (sort keys %docfuncs) {
 195     # Have you used a full for apidoc or just a func name?
 196     # Have you used Ap instead of Am in the for apidoc?
 197     warn "Unable to place $_!\n";
 198 }
 199
 200 print DOC <<'_EOB_';
 201 =head1 NAME
 202
 203 perlapi - autogenerated documentation for the perl public API
 204
 205 =head1 DESCRIPTION
 206 X<Perl API> X<API> X<api>
 207
 208 This file contains the documentation of the perl public API generated by
 209 embed.pl, specifically a listing of functions, macros, flags, and variables
 210 that may be used by extension writers.  The interfaces of any functions that
 211 are not listed here are subject to change without notice.  For this reason,
 212 blindly using functions listed in proto.h is to be avoided when writing
 213 extensions.
 214
 215 Note that all Perl API global variables must be referenced with the C<PL_>
 216 prefix.  Some macros are provided for compatibility with the older,
 217 unadorned names, but this support may be disabled in a future release.
 218
 219 The listing is alphabetical, case insensitive.
 220
 221 _EOB_
 222
 223 my $key;
 224 # case insensitive sort, with fallback for determinacy
 225 for $key (sort { uc($a) cmp uc($b) || $a cmp $b } keys %apidocs) {
 226     my $section = $apidocs{$key};
 227     print DOC "\n=head1 $key\n\n=over 8\n\n";
 228     # Again, fallback for determinacy
 229     for my $key (sort { uc($a) cmp uc($b) || $a cmp $b } keys %$section) {
 230         docout(\*DOC, $key, $section->{$key});
 231     }
 232     print DOC "\n=back\n";
 233 }
 234
 235 print DOC <<'_EOE_';
 236
 237 =head1 AUTHORS
 238
 239 Until May 1997, this document was maintained by Jeff Okamoto
 240 <okamoto@corp.hp.com>.  It is now maintained as part of Perl itself.
 241
 242 With lots of help and suggestions from Dean Roehrich, Malcolm Beattie,
 243 Andreas Koenig, Paul Hudson, Ilya Zakharevich, Paul Marquess, Neil
 244 Bowers, Matthew Green, Tim Bunce, Spider Boardman, Ulrich Pfeifer,
 245 Stephen McCamant, and Gurusamy Sarathy.
 246
 247 API Listing originally by Dean Roehrich <roehrich@cray.com>.
 248
 249 Updated to be autogenerated from comments in the source by Benjamin Stuhl.
 250
 251 =head1 SEE ALSO
 252
 253 perlguts(1), perlxs(1), perlxstut(1), perlintern(1)
 254
 255 _EOE_
 256
 257
 258 close(DOC) or die "Error closing pod/perlapi.pod: $!";
 259
 260 safer_unlink "pod/perlintern.pod";
 261 open(GUTS, ">pod/perlintern.pod") or
 262                 die "Unable to create pod/perlintern.pod: $!\n";
 263 binmode GUTS;
 264 print GUTS <<'END';
 265 =head1 NAME
 266
 267 perlintern - autogenerated documentation of purely B<internal>
 268                  Perl functions
 269
 270 =head1 DESCRIPTION
 271 X<internal Perl functions> X<interpreter functions>
 272
 273 This file is the autogenerated documentation of functions in the
 274 Perl interpreter that are documented using Perl's internal documentation
 275 format but are not marked as part of the Perl API. In other words,
 276 B<they are not for use in extensions>!
 277
 278 END
 279
 280 for $key (sort { uc($a) cmp uc($b); } keys %gutsdocs) {
 281     my $section = $gutsdocs{$key};
 282     print GUTS "\n=head1 $key\n\n=over 8\n\n";
 283     for my $key (sort { uc($a) cmp uc($b); } keys %$section) {
 284         docout(\*GUTS, $key, $section->{$key});
 285     }
 286     print GUTS "\n=back\n";
 287 }
 288
 289 print GUTS <<'END';
 290
 291 =head1 AUTHORS
 292
 293 The autodocumentation system was originally added to the Perl core by
 294 Benjamin Stuhl. Documentation is by whoever was kind enough to
 295 document their functions.
 296
 297 =head1 SEE ALSO
 298
 299 perlguts(1), perlapi(1)
 300
 301 END
 302
 303 close GUTS or die "Error closing pod/perlintern.pod: $!";