Double magic with '\&$x'
[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 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);