staticperl/perl/autodoc.pl

#!/usr/bin/perl -w

require 5.003;  # keep this compatible, an old perl is all we may have before
                # we build the new one

BEGIN {
  push @INC, 'lib';
  require 'regen_lib.pl';
}


#
# See database of global and static function prototypes in embed.fnc
# This is used to generate prototype headers under various configurations,
# export symbols lists for different platforms, and macros to provide an
# implicit interpreter context argument.
#

open IN, "embed.fnc" or die $!;

# walk table providing an array of components in each line to
# subroutine, printing the result
sub walk_table (&@) {
    my $function = shift;
    my $filename = shift || '-';
    my $leader = shift;
    my $trailer = shift;
    my $F;
    local *F;
    if (ref $filename) {        # filehandle
        $F = $filename;
    }
    else {
        safer_unlink $filename;
        open F, ">$filename" or die "Can't open $filename: $!";
        binmode F;
        $F = \*F;
    }
    print $F $leader if $leader;
    seek IN, 0, 0;              # so we may restart
    while (<IN>) {
        chomp;
        next if /^:/;
        while (s|\\\s*$||) {
            $_ .= <IN>;
            chomp;
        }
        s/\s+$//;
        my @args;
        if (/^\s*(#|$)/) {
            @args = $_;
        }
        else {
            @args = split /\s*\|\s*/, $_;
        }
        print $F $function->(@args);
    }
    print $F $trailer if $trailer;
    unless (ref $filename) {
        close $F or die "Error closing $filename: $!";
    }
}

my %apidocs;
my %gutsdocs;
my %docfuncs;

my $curheader = "Unknown section";

sub autodoc ($$) { # parse a file and extract documentation info
    my($fh,$file) = @_;
    my($in, $doc, $line);
FUNC:
    while (defined($in = <$fh>)) {
        if ($in=~ /^=head1 (.*)/) {
            $curheader = $1;
            next FUNC;
        }
        $line++;
        if ($in =~ /^=for\s+apidoc\s+(.*?)\s*\n/) {
            my $proto = $1;
            $proto = "||$proto" unless $proto =~ /\|/;
            my($flags, $ret, $name, @args) = split /\|/, $proto;
            my $docs = "";
DOC:
            while (defined($doc = <$fh>)) {
                $line++;
                last DOC if $doc =~ /^=\w+/;
                if ($doc =~ m:^\*/$:) {
                    warn "=cut missing? $file:$line:$doc";;
                    last DOC;
                }
                $docs .= $doc;
            }
            $docs = "\n$docs" if $docs and $docs !~ /^\n/;
            if ($flags =~ /m/) {
                if ($flags =~ /A/) {
                    $apidocs{$curheader}{$name} = [$flags, $docs, $ret, $file, @args];
                }
                else {
                    $gutsdocs{$curheader}{$name} = [$flags, $docs, $ret, $file, @args];
                }
            }
            else {
                $docfuncs{$name} = [$flags, $docs, $ret, $file, $curheader, @args];
            }
            if (defined $doc) {
                if ($doc =~ /^=(?:for|head)/) {
                    $in = $doc;
                    redo FUNC;
                }
            } else {
                warn "$file:$line:$in";
            }
        }
    }
}

sub docout ($$$) { # output the docs for one function
    my($fh, $name, $docref) = @_;
    my($flags, $docs, $ret, $file, @args) = @$docref;

    $docs .= "NOTE: this function is experimental and may change or be
removed without notice.\n\n" if $flags =~ /x/;
    $docs .= "NOTE: the perl_ form of this function is deprecated.\n\n"
        if $flags =~ /p/;

    print $fh "=item $name\n$docs";

    if ($flags =~ /U/) { # no usage
        # nothing
    } elsif ($flags =~ /s/) { # semicolon ("dTHR;")
        print $fh "\t\t$name;\n\n";
    } elsif ($flags =~ /n/) { # no args
        print $fh "\t$ret\t$name\n\n";
    } else { # full usage
        print $fh "\t$ret\t$name";
        print $fh "(" . join(", ", @args) . ")";
        print $fh "\n\n";
    }
    print $fh "=for hackers\nFound in file $file\n\n";
}

my $file;
# glob() picks up docs from extra .c or .h files that may be in unclean
# development trees.
my $MANIFEST = do {
  local ($/, *FH);
  open FH, "MANIFEST" or die "Can't open MANIFEST: $!";
  <FH>;
};

for $file (($MANIFEST =~ /^(\S+\.c)\t/gm), ($MANIFEST =~ /^(\S+\.h)\t/gm)) {
    open F, "< $file" or die "Cannot open $file for docs: $!\n";
    $curheader = "Functions in file $file\n";
    autodoc(\*F,$file);
    close F or die "Error closing $file: $!\n";
}

safer_unlink "pod/perlapi.pod";
open (DOC, ">pod/perlapi.pod") or
        die "Can't create pod/perlapi.pod: $!\n";
binmode DOC;

walk_table {    # load documented functions into approriate hash
    if (@_ > 1) {
        my($flags, $retval, $func, @args) = @_;
        return "" unless $flags =~ /d/;
        $func =~ s/\t//g; $flags =~ s/p//; # clean up fields from embed.pl
        $retval =~ s/\t//;
        my $docref = delete $docfuncs{$func};
        if ($docref and @$docref) {
            if ($flags =~ /A/) {
                $docref->[0].="x" if $flags =~ /M/;
                $apidocs{$docref->[4]}{$func} = 
                    [$docref->[0] . 'A', $docref->[1], $retval,
                                                $docref->[3], @args];
            } else {
                $gutsdocs{$docref->[4]}{$func} = 
                    [$docref->[0], $docref->[1], $retval, $docref->[3], @args];
            }
        }
        else {
            warn "no docs for $func\n" unless $docref and @$docref;
        }
    }
    return "";
} \*DOC;

for (sort keys %docfuncs) {
    # Have you used a full for apidoc or just a func name?
    # Have you used Ap instead of Am in the for apidoc?
    warn "Unable to place $_!\n";
}

print DOC <<'_EOB_';
=head1 NAME

perlapi - autogenerated documentation for the perl public API

=head1 DESCRIPTION

This file contains the documentation of the perl public API generated by
embed.pl, specifically a listing of functions, macros, flags, and variables
that may be used by extension writers.  The interfaces of any functions that
are not listed here are subject to change without notice.  For this reason,
blindly using functions listed in proto.h is to be avoided when writing
extensions.

Note that all Perl API global variables must be referenced with the C<PL_>
prefix.  Some macros are provided for compatibility with the older,
unadorned names, but this support may be disabled in a future release.

The listing is alphabetical, case insensitive.

_EOB_

my $key;
# case insensitive sort, with fallback for determinacy
for $key (sort { uc($a) cmp uc($b) || $a cmp $b } keys %apidocs) {
    my $section = $apidocs{$key}; 
    print DOC "\n=head1 $key\n\n=over 8\n\n";
    # Again, fallback for determinacy
    for my $key (sort { uc($a) cmp uc($b) || $a cmp $b } keys %$section) {
        docout(\*DOC, $key, $section->{$key});
    }
    print DOC "\n=back\n";
}

print DOC <<'_EOE_';

=head1 AUTHORS

Until May 1997, this document was maintained by Jeff Okamoto
<okamoto@corp.hp.com>.  It is now maintained as part of Perl itself.

With lots of help and suggestions from Dean Roehrich, Malcolm Beattie,
Andreas Koenig, Paul Hudson, Ilya Zakharevich, Paul Marquess, Neil
Bowers, Matthew Green, Tim Bunce, Spider Boardman, Ulrich Pfeifer,
Stephen McCamant, and Gurusamy Sarathy.

API Listing originally by Dean Roehrich <roehrich@cray.com>.

Updated to be autogenerated from comments in the source by Benjamin Stuhl.

=head1 SEE ALSO

perlguts(1), perlxs(1), perlxstut(1), perlintern(1)

_EOE_


close(DOC) or die "Error closing pod/perlapi.pod: $!";

safer_unlink "pod/perlintern.pod";
open(GUTS, ">pod/perlintern.pod") or
                die "Unable to create pod/perlintern.pod: $!\n";
binmode GUTS;
print GUTS <<'END';
=head1 NAME

perlintern - autogenerated documentation of purely B<internal>
                 Perl functions

=head1 DESCRIPTION

This file is the autogenerated documentation of functions in the
Perl interpreter that are documented using Perl's internal documentation
format but are not marked as part of the Perl API. In other words,
B<they are not for use in extensions>!

END

for $key (sort { uc($a) cmp uc($b); } keys %gutsdocs) {
    my $section = $gutsdocs{$key}; 
    print GUTS "\n=head1 $key\n\n=over 8\n\n";
    for my $key (sort { uc($a) cmp uc($b); } keys %$section) {
        docout(\*GUTS, $key, $section->{$key});
    }
    print GUTS "\n=back\n";
}

print GUTS <<'END';

=head1 AUTHORS

The autodocumentation system was originally added to the Perl core by
Benjamin Stuhl. Documentation is by whoever was kind enough to
document their functions.

=head1 SEE ALSO

perlguts(1), perlapi(1)

END

close GUTS or die "Error closing pod/perlintern.pod: $!";
Revision:	1.1
Committed:	Thu Jun 30 14:26:41 2005 UTC (21 years, 3 months ago) by root
Content type:	text/plain
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.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			print $F $function->(@args);
57			}
58			print $F $trailer if $trailer;
59			unless (ref $filename) {
60			close $F or die "Error closing $filename: $!";
61			}
62			}
63
64			my %apidocs;
65			my %gutsdocs;
66			my %docfuncs;
67
68			my $curheader = "Unknown section";
69
70			sub autodoc ($$) { # parse a file and extract documentation info
71			my($fh,$file) = @_;
72			my($in, $doc, $line);
73			FUNC:
74			while (defined($in = <$fh>)) {
75			if ($in=~ /^=head1 (.*)/) {
76			$curheader = $1;
77			next FUNC;
78			}
79			$line++;
80			if ($in =~ /^=for\s+apidoc\s+(.?)\s\n/) {
81			my $proto = $1;
82			$proto = "\|\|$proto" unless $proto =~ /\\|/;
83			my($flags, $ret, $name, @args) = split /\\|/, $proto;
84			my $docs = "";
85			DOC:
86			while (defined($doc = <$fh>)) {
87			$line++;
88			last DOC if $doc =~ /^=\w+/;
89			if ($doc =~ m:^\*/$:) {
90			warn "=cut missing? $file:$line:$doc";;
91			last DOC;
92			}
93			$docs .= $doc;
94			}
95			$docs = "\n$docs" if $docs and $docs !~ /^\n/;
96			if ($flags =~ /m/) {
97			if ($flags =~ /A/) {
98			$apidocs{$curheader}{$name} = [$flags, $docs, $ret, $file, @args];
99			}
100			else {
101			$gutsdocs{$curheader}{$name} = [$flags, $docs, $ret, $file, @args];
102			}
103			}
104			else {
105			$docfuncs{$name} = [$flags, $docs, $ret, $file, $curheader, @args];
106			}
107			if (defined $doc) {
108			if ($doc =~ /^=(?:for\|head)/) {
109			$in = $doc;
110			redo FUNC;
111			}
112			} else {
113			warn "$file:$line:$in";
114			}
115			}
116			}
117			}
118
119			sub docout ($$$) { # output the docs for one function
120			my($fh, $name, $docref) = @_;
121			my($flags, $docs, $ret, $file, @args) = @$docref;
122
123			$docs .= "NOTE: this function is experimental and may change or be
124			removed without notice.\n\n" if $flags =~ /x/;
125			$docs .= "NOTE: the perl_ form of this function is deprecated.\n\n"
126			if $flags =~ /p/;
127
128			print $fh "=item $name\n$docs";
129
130			if ($flags =~ /U/) { # no usage
131			# nothing
132			} elsif ($flags =~ /s/) { # semicolon ("dTHR;")
133			print $fh "\t\t$name;\n\n";
134			} elsif ($flags =~ /n/) { # no args
135			print $fh "\t$ret\t$name\n\n";
136			} else { # full usage
137			print $fh "\t$ret\t$name";
138			print $fh "(" . join(", ", @args) . ")";
139			print $fh "\n\n";
140			}
141			print $fh "=for hackers\nFound in file $file\n\n";
142			}
143
144			my $file;
145			# glob() picks up docs from extra .c or .h files that may be in unclean
146			# development trees.
147			my $MANIFEST = do {
148			local ($/, *FH);
149			open FH, "MANIFEST" or die "Can't open MANIFEST: $!";
150			<FH>;
151			};
152
153			for $file (($MANIFEST =~ /^(\S+\.c)\t/gm), ($MANIFEST =~ /^(\S+\.h)\t/gm)) {
154			open F, "< $file" or die "Cannot open $file for docs: $!\n";
155			$curheader = "Functions in file $file\n";
156			autodoc(\*F,$file);
157			close F or die "Error closing $file: $!\n";
158			}
159
160			safer_unlink "pod/perlapi.pod";
161			open (DOC, ">pod/perlapi.pod") or
162			die "Can't create pod/perlapi.pod: $!\n";
163			binmode DOC;
164
165			walk_table { # load documented functions into approriate hash
166			if (@_ > 1) {
167			my($flags, $retval, $func, @args) = @_;
168			return "" unless $flags =~ /d/;
169			$func =~ s/\t//g; $flags =~ s/p//; # clean up fields from embed.pl
170			$retval =~ s/\t//;
171			my $docref = delete $docfuncs{$func};
172			if ($docref and @$docref) {
173			if ($flags =~ /A/) {
174			$docref->[0].="x" if $flags =~ /M/;
175			$apidocs{$docref->[4]}{$func} =
176			[$docref->[0] . 'A', $docref->[1], $retval,
177			$docref->[3], @args];
178			} else {
179			$gutsdocs{$docref->[4]}{$func} =
180			[$docref->[0], $docref->[1], $retval, $docref->[3], @args];
181			}
182			}
183			else {
184			warn "no docs for $func\n" unless $docref and @$docref;
185			}
186			}
187			return "";
188			} \*DOC;
189
190			for (sort keys %docfuncs) {
191			# Have you used a full for apidoc or just a func name?
192			# Have you used Ap instead of Am in the for apidoc?
193			warn "Unable to place $_!\n";
194			}
195
196			print DOC <<'_EOB_';
197			=head1 NAME
198
199			perlapi - autogenerated documentation for the perl public API
200
201			=head1 DESCRIPTION
202
203			This file contains the documentation of the perl public API generated by
204			embed.pl, specifically a listing of functions, macros, flags, and variables
205			that may be used by extension writers. The interfaces of any functions that
206			are not listed here are subject to change without notice. For this reason,
207			blindly using functions listed in proto.h is to be avoided when writing
208			extensions.
209
210			Note that all Perl API global variables must be referenced with the C<PL_>
211			prefix. Some macros are provided for compatibility with the older,
212			unadorned names, but this support may be disabled in a future release.
213
214			The listing is alphabetical, case insensitive.
215
216			_EOB_
217
218			my $key;
219			# case insensitive sort, with fallback for determinacy
220			for $key (sort { uc($a) cmp uc($b) \|\| $a cmp $b } keys %apidocs) {
221			my $section = $apidocs{$key};
222			print DOC "\n=head1 $key\n\n=over 8\n\n";
223			# Again, fallback for determinacy
224			for my $key (sort { uc($a) cmp uc($b) \|\| $a cmp $b } keys %$section) {
225			docout(\*DOC, $key, $section->{$key});
226			}
227			print DOC "\n=back\n";
228			}
229
230			print DOC <<'_EOE_';
231
232			=head1 AUTHORS
233
234			Until May 1997, this document was maintained by Jeff Okamoto
235			<okamoto@corp.hp.com>. It is now maintained as part of Perl itself.
236
237			With lots of help and suggestions from Dean Roehrich, Malcolm Beattie,
238			Andreas Koenig, Paul Hudson, Ilya Zakharevich, Paul Marquess, Neil
239			Bowers, Matthew Green, Tim Bunce, Spider Boardman, Ulrich Pfeifer,
240			Stephen McCamant, and Gurusamy Sarathy.
241
242			API Listing originally by Dean Roehrich <roehrich@cray.com>.
243
244			Updated to be autogenerated from comments in the source by Benjamin Stuhl.
245
246			=head1 SEE ALSO
247
248			perlguts(1), perlxs(1), perlxstut(1), perlintern(1)
249
250			_EOE_
251
252
253			close(DOC) or die "Error closing pod/perlapi.pod: $!";
254
255			safer_unlink "pod/perlintern.pod";
256			open(GUTS, ">pod/perlintern.pod") or
257			die "Unable to create pod/perlintern.pod: $!\n";
258			binmode GUTS;
259			print GUTS <<'END';
260			=head1 NAME
261
262			perlintern - autogenerated documentation of purely B<internal>
263			Perl functions
264
265			=head1 DESCRIPTION
266
267			This file is the autogenerated documentation of functions in the
268			Perl interpreter that are documented using Perl's internal documentation
269			format but are not marked as part of the Perl API. In other words,
270			B<they are not for use in extensions>!
271
272			END
273
274			for $key (sort { uc($a) cmp uc($b); } keys %gutsdocs) {
275			my $section = $gutsdocs{$key};
276			print GUTS "\n=head1 $key\n\n=over 8\n\n";
277			for my $key (sort { uc($a) cmp uc($b); } keys %$section) {
278			docout(\*GUTS, $key, $section->{$key});
279			}
280			print GUTS "\n=back\n";
281			}
282
283			print GUTS <<'END';
284
285			=head1 AUTHORS
286
287			The autodocumentation system was originally added to the Perl core by
288			Benjamin Stuhl. Documentation is by whoever was kind enough to
289			document their functions.
290
291			=head1 SEE ALSO
292
293			perlguts(1), perlapi(1)
294
295			END
296
297			close GUTS or die "Error closing pod/perlintern.pod: $!";