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