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 sub readonly_header (*) {
 148     my $fh = shift;
 149     print $fh <<"_EOH_";
 150 -*- buffer-read-only: t -*-
 151
 152 !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 153 This file is built by $0 extracting documentation from the C source
 154 files.
 155
 156 _EOH_
 157 }
 158
 159 sub readonly_footer (*) {
 160     my $fh = shift;
 161     print $fh <<'_EOF_';
 162 =cut
 163
 164  ex: set ro:
 165 _EOF_
 166 }
 167
 168 my $file;
 169 # glob() picks up docs from extra .c or .h files that may be in unclean
 170 # development trees.
 171 my $MANIFEST = do {
 172   local ($/, *FH);
 173   open FH, "MANIFEST" or die "Can't open MANIFEST: $!";
 174   <FH>;
 175 };
 176
 177 for $file (($MANIFEST =~ /^(\S+\.c)\t/gm), ($MANIFEST =~ /^(\S+\.h)\t/gm)) {
 178     open F, "< $file" or die "Cannot open $file for docs: $!\n";
 179     $curheader = "Functions in file $file\n";
 180     autodoc(\*F,$file);
 181     close F or die "Error closing $file: $!\n";
 182 }
 183
 184 safer_unlink "pod/perlapi.pod";
 185 open (DOC, ">pod/perlapi.pod") or
 186         die "Can't create pod/perlapi.pod: $!\n";
 187 binmode DOC;
 188
 189 walk_table {    # load documented functions into appropriate hash
 190     if (@_ > 1) {
 191         my($flags, $retval, $func, @args) = @_;
 192         return "" unless $flags =~ /d/;
 193         $func =~ s/\t//g; $flags =~ s/p//; # clean up fields from embed.pl
 194         $retval =~ s/\t//;
 195         my $docref = delete $docfuncs{$func};
 196         $seenfuncs{$func} = 1;
 197         if ($docref and @$docref) {
 198             if ($flags =~ /A/) {
 199                 $docref->[0].="x" if $flags =~ /M/;
 200                 $apidocs{$docref->[4]}{$func} =
 201                     [$docref->[0] . 'A', $docref->[1], $retval, $docref->[3],
 202                         @args];
 203             } else {
 204                 $gutsdocs{$docref->[4]}{$func} =
 205                     [$docref->[0], $docref->[1], $retval, $docref->[3], @args];
 206             }
 207         }
 208         else {
 209             warn "no docs for $func\n" unless $seenfuncs{$func};
 210         }
 211     }
 212     return "";
 213 } \*DOC;
 214
 215 for (sort keys %docfuncs) {
 216     # Have you used a full for apidoc or just a func name?
 217     # Have you used Ap instead of Am in the for apidoc?
 218     warn "Unable to place $_!\n";
 219 }
 220
 221 readonly_header(DOC);
 222
 223 print DOC <<'_EOB_';
 224 =head1 NAME
 225
 226 perlapi - autogenerated documentation for the perl public API
 227
 228 =head1 DESCRIPTION
 229 X<Perl API> X<API> X<api>
 230
 231 This file contains the documentation of the perl public API generated by
 232 embed.pl, specifically a listing of functions, macros, flags, and variables
 233 that may be used by extension writers.  The interfaces of any functions that
 234 are not listed here are subject to change without notice.  For this reason,
 235 blindly using functions listed in proto.h is to be avoided when writing
 236 extensions.
 237
 238 Note that all Perl API global variables must be referenced with the C<PL_>
 239 prefix.  Some macros are provided for compatibility with the older,
 240 unadorned names, but this support may be disabled in a future release.
 241
 242 The listing is alphabetical, case insensitive.
 243
 244 _EOB_
 245
 246 my $key;
 247 # case insensitive sort, with fallback for determinacy
 248 for $key (sort { uc($a) cmp uc($b) || $a cmp $b } keys %apidocs) {
 249     my $section = $apidocs{$key};
 250     print DOC "\n=head1 $key\n\n=over 8\n\n";
 251     # Again, fallback for determinacy
 252     for my $key (sort { uc($a) cmp uc($b) || $a cmp $b } keys %$section) {
 253         docout(\*DOC, $key, $section->{$key});
 254     }
 255     print DOC "\n=back\n";
 256 }
 257
 258 print DOC <<'_EOE_';
 259
 260 =head1 AUTHORS
 261
 262 Until May 1997, this document was maintained by Jeff Okamoto
 263 <okamoto@corp.hp.com>.  It is now maintained as part of Perl itself.
 264
 265 With lots of help and suggestions from Dean Roehrich, Malcolm Beattie,
 266 Andreas Koenig, Paul Hudson, Ilya Zakharevich, Paul Marquess, Neil
 267 Bowers, Matthew Green, Tim Bunce, Spider Boardman, Ulrich Pfeifer,
 268 Stephen McCamant, and Gurusamy Sarathy.
 269
 270 API Listing originally by Dean Roehrich <roehrich@cray.com>.
 271
 272 Updated to be autogenerated from comments in the source by Benjamin Stuhl.
 273
 274 =head1 SEE ALSO
 275
 276 perlguts(1), perlxs(1), perlxstut(1), perlintern(1)
 277
 278 _EOE_
 279
 280 readonly_footer(DOC);
 281
 282 close(DOC) or die "Error closing pod/perlapi.pod: $!";
 283
 284 safer_unlink "pod/perlintern.pod";
 285 open(GUTS, ">pod/perlintern.pod") or
 286                 die "Unable to create pod/perlintern.pod: $!\n";
 287 binmode GUTS;
 288 readonly_header(GUTS);
 289 print GUTS <<'END';
 290 =head1 NAME
 291
 292 perlintern - autogenerated documentation of purely B<internal>
 293                  Perl functions
 294
 295 =head1 DESCRIPTION
 296 X<internal Perl functions> X<interpreter functions>
 297
 298 This file is the autogenerated documentation of functions in the
 299 Perl interpreter that are documented using Perl's internal documentation
 300 format but are not marked as part of the Perl API. In other words,
 301 B<they are not for use in extensions>!
 302
 303 END
 304
 305 for $key (sort { uc($a) cmp uc($b); } keys %gutsdocs) {
 306     my $section = $gutsdocs{$key};
 307     print GUTS "\n=head1 $key\n\n=over 8\n\n";
 308     for my $key (sort { uc($a) cmp uc($b); } keys %$section) {
 309         docout(\*GUTS, $key, $section->{$key});
 310     }
 311     print GUTS "\n=back\n";
 312 }
 313
 314 print GUTS <<'END';
 315
 316 =head1 AUTHORS
 317
 318 The autodocumentation system was originally added to the Perl core by
 319 Benjamin Stuhl. Documentation is by whoever was kind enough to
 320 document their functions.
 321
 322 =head1 SEE ALSO
 323
 324 perlguts(1), perlapi(1)
 325
 326 END
 327 readonly_footer(GUTS);
 328
 329 close GUTS or die "Error closing pod/perlintern.pod: $!";