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 Perl was originally written to handle US-ASCII only (that is characters
 242 whose ordinal numbers are in the range 0 - 127).
 243 And documentation and comments may still use the term ASCII, when
 244 sometimes in fact the entire range from 0 - 255 is meant.
 245
 246 Note that Perl can be compiled and run under EBCDIC (See L<perlebcdic>)
 247 or ASCII.  Most of the documentation (and even comments in the code)
 248 ignore the EBCDIC possibility.
 249 For almost all purposes the differences are transparent.
 250 As an example, under EBCDIC,
 251 instead of UTF-8, UTF-EBCDIC is used to encode Unicode strings, and so
 252 whenever this documentation refers to C<utf8>
 253 (and variants of that name, including in function names),
 254 it also (essentially transparently) means C<UTF-EBCDIC>.
 255 But the ordinals of characters differ between ASCII, EBCDIC, and
 256 the UTF- encodings, and a string encoded in UTF-EBCDIC may occupy more bytes
 257 than in UTF-8.
 258
 259 Also, on some EBCDIC machines, functions that are documented as operating on
 260 US-ASCII (or Basic Latin in Unicode terminology) may in fact operate on all
 261 256 characters in the EBCDIC range, not just the subset corresponding to
 262 US-ASCII.
 263
 264 The listing below is alphabetical, case insensitive.
 265
 266 _EOB_
 267
 268 my $key;
 269 # case insensitive sort, with fallback for determinacy
 270 for $key (sort { uc($a) cmp uc($b) || $a cmp $b } keys %apidocs) {
 271     my $section = $apidocs{$key};
 272     print $doc "\n=head1 $key\n\n=over 8\n\n";
 273     # Again, fallback for determinacy
 274     for my $key (sort { uc($a) cmp uc($b) || $a cmp $b } keys %$section) {
 275         docout($doc, $key, $section->{$key});
 276     }
 277     print $doc "\n=back\n";
 278 }
 279
 280 print $doc <<'_EOE_';
 281
 282 =head1 AUTHORS
 283
 284 Until May 1997, this document was maintained by Jeff Okamoto
 285 <okamoto@corp.hp.com>.  It is now maintained as part of Perl itself.
 286
 287 With lots of help and suggestions from Dean Roehrich, Malcolm Beattie,
 288 Andreas Koenig, Paul Hudson, Ilya Zakharevich, Paul Marquess, Neil
 289 Bowers, Matthew Green, Tim Bunce, Spider Boardman, Ulrich Pfeifer,
 290 Stephen McCamant, and Gurusamy Sarathy.
 291
 292 API Listing originally by Dean Roehrich <roehrich@cray.com>.
 293
 294 Updated to be autogenerated from comments in the source by Benjamin Stuhl.
 295
 296 =head1 SEE ALSO
 297
 298 perlguts(1), perlxs(1), perlxstut(1), perlintern(1)
 299
 300 _EOE_
 301
 302 readonly_footer($doc);
 303
 304 safer_close($doc);
 305
 306 safer_unlink "pod/perlintern.pod";
 307 my $guts = safer_open("pod/perlintern.pod");
 308 readonly_header($guts);
 309 print $guts <<'END';
 310 =head1 NAME
 311
 312 perlintern - autogenerated documentation of purely B<internal>
 313                  Perl functions
 314
 315 =head1 DESCRIPTION
 316 X<internal Perl functions> X<interpreter functions>
 317
 318 This file is the autogenerated documentation of functions in the
 319 Perl interpreter that are documented using Perl's internal documentation
 320 format but are not marked as part of the Perl API. In other words,
 321 B<they are not for use in extensions>!
 322
 323 END
 324
 325 for $key (sort { uc($a) cmp uc($b); } keys %gutsdocs) {
 326     my $section = $gutsdocs{$key};
 327     print $guts "\n=head1 $key\n\n=over 8\n\n";
 328     for my $key (sort { uc($a) cmp uc($b); } keys %$section) {
 329         docout($guts, $key, $section->{$key});
 330     }
 331     print $guts "\n=back\n";
 332 }
 333
 334 print $guts <<'END';
 335
 336 =head1 AUTHORS
 337
 338 The autodocumentation system was originally added to the Perl core by
 339 Benjamin Stuhl. Documentation is by whoever was kind enough to
 340 document their functions.
 341
 342 =head1 SEE ALSO
 343
 344 perlguts(1), perlapi(1)
 345
 346 END
 347 readonly_footer($guts);
 348
 349 safer_close($guts);