# $Id$
$VERSION{''.__FILE__} = '$Revision$';
#
# >>Title::     Perl API Extraction Driver
#
# >>Copyright::
# Copyright (c) 1992-1996, Ian Clatworthy (ianc@mincom.com).
# You may distribute under the terms specified in the LICENSE file.
#
# >>History::
# -----------------------------------------------------------------------
# Date      Who     Change
# 29-Feb-96 ianc    SDF 2.000
# -----------------------------------------------------------------------
#
# >>Purpose::
# This library provides a driver for extracting the API from
# [[Perl]] libraries.
#
# >>Description::
#
# >>Limitations::
#
# >>Resources::
#
# >>Implementation::
#

##### Constants #####

##### Variables #####
$_perl_cnt = 0;

##### Routines #####

#
# >>Description::
# {{Y:PerlFetch}} returns ($success, @records). {{success}} is 1
# if the file is opened successfully. Each record is a perl
# line of code. i.e. blank lines are removed.
#
sub PerlFetch {
    local($file) = @_;
    local($success, @records);
    local(
      $strm,
      $state
    );

    # Get the input stream
    $strm = sprintf("perl_s%d", $_perl_cnt++);

    # Open the file
    $success = open($strm, $file);

    # Input the records
    @records = ();
    if ($success) {

        $state = 0;
        perl_record:
        while (<$strm>) {

            # remove the trailing new-line
            chop($_);

            # skip blank lines
            if (/^\s*$/) {
                $state = 0;
                next;
            }

            push(@records, $_);
        }
        close($strm);

    }

    # return results
    return ($success, @records);
}

#
# >>Description::
# {{Y:PerlSymbols}} returns the list of perl symbols in a file.
# Supported symbol types are:
#
# * {{sub}} - subroutines
# * {{var}} - variables
#
# If {{symbol_type}} is supplied, only symbols of those types are
# returned. Otherwise, all symbols are returned. If {{pattern}} is
# supplied, only symbols matching that pattern are returned.
# Each symbol is returned as a record in the format:
#
# =     symbol_type:name:result:parameters
#
# The {{result}} and {{parameters}} fields are only present for
# subroutine symbols.
#
# >>Limitations::
# {{Y:PerlSymbols}} doesn't handle packages yet. i.e. doesn't append
# current package name to the front of each name.
#
sub PerlSymbols {
    local(*perl, $pattern, @symbol_type) = @_;
    local(@symbol);
    local($i, $sub_name, $sub_args, $sub_result);
    local($get_subs, $get_vars);
    local($var_name);

    # Decide on what symbols to extract
    if (@symbol_type) {
        $get_subs = grep(/^sub$/, @symbol_type);
        $get_vars = grep(/^var$/, @symbol_type);
    }
    else {
        $get_subs = 1;
        $get_vars = 1;
    }

    # Extract Interface
    line:
    for ($i = 0; $i < $#perl - 1; $i++) {

        if ($get_subs && $perl[$i] =~ /^sub\s+(\w+)\s*\{/) {
            $sub_name = $1;
            if ($pattern && $sub_name !~ /$pattern/) {
                next line;
            }
            $perl[$i + 1] =~ /local\((.*)\)\s*\=\s*\@\_\;/;
            $sub_args = $1;
            $perl[$i + 2] =~ /local\((.*)\)\s*\;/;
            $sub_result = $1;
            if ($sub_result =~ /,/) {
                $sub_result = "($sub_result)";
            }
            push(@symbol, join(':', 'sub', $sub_name,
              $sub_result, $sub_args));
            $i += 2;
        }
        elsif ($get_vars && $perl[$i] =~ /^([\$\@\%])(\w+)\s+/) {
            $var_type = $1;
            $var_name = $2;
            if ($pattern && $var_name !~ /$pattern/) {
                next line;
            }
            push(@symbol, join(':', 'var', "$var_type$var_name"));
        }
    }

    # return result
    return @symbol;
}

# package return value
1;