Fix a couple of warnings
[p5sagit/p5-mst-13.2.git] / 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: $!";