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