source: trunk/essentials/dev-lang/perl/autodoc.pl@ 3310

#!/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*/, $_;
        }
        s/\b(NN|NULLOK)\b\s+//g for @args;
        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;
    $name =~ s/\s*$//;

    $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\nX<$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>;
};