view release on metacpan or  search on metacpan

lib/App/Test/Generator/SchemaExtractor.pm  view on Meta::CPAN

	my $statements = $doc->find(
		sub {
			$_[1]->isa('PPI::Statement') && $_[1]->content =~ /^\s*signature_for\b/
		}
	) or return;

	foreach my $stmt (@$statements) {
		my $content = $stmt->content;
		if ($content =~ /^\s*signature_for\s+\Q$function\E\b/) {
			return $stmt;
		}
	}

	return;
}

# --------------------------------------------------
# _extract_signature_expression
#
# Purpose:    Extract the Type::Params signature
#             expression (everything after =>) from
#             a signature_for statement node.
#
# Entry:      $stmt     - PPI::Statement node.
#             $function - function name string,
#                         used in the match pattern.
#
# Exit:       Returns the signature expression
#             string, or undef if the pattern
#             does not match.
#
# Side effects: None.
# --------------------------------------------------
sub _extract_signature_expression {
	my ($self, $stmt, $function) = @_;

	my $content = $stmt->content;

	if ($content =~ /^\s*signature_for\s+\Q$function\E\s*=>\s*(.+?);?\s*$/s) {
		return $1;
	}

	return;
}

# --------------------------------------------------
# _compile_signature_isolated
#
# Purpose:    Compile and evaluate a Type::Params
#             signature expression in an isolated
#             environment to extract parameter
#             metadata without polluting the
#             current process.
#
# Entry:      $function        - function name string.
#             $signature_expr  - Type::Params
#                                signature expression
#                                string.
#
# Exit:       Returns a decoded JSON hashref
#             containing parameters and returns
#             metadata on success.
#             Croaks on unsafe expressions, timeout,
#             or compile errors.
#
# Side effects: May fork a child process with a
#               memory limit applied via
#               BSD::Resource if available.
#               Memory limiting is best-effort and
#               silently skipped on platforms where
#               BSD::Resource is unavailable.
# --------------------------------------------------
sub _compile_signature_isolated {
	my ($self, $function, $signature_expr) = @_;

	# Remove comments
	$signature_expr =~ s/#.*$//mg;

	# Reject obviously dangerous constructs
	if ($signature_expr =~ /\b(?:system|exec|open|fork|require|do|eval|qx)\b/) {
		die 'Unsafe signature expression';
	}

	if ($signature_expr =~ /[`{};]/) {
		die "Unsafe signature expression";
	}

	my $payload = <<'PERL';
use strict;
use warnings;
use Type::Params -sigs;
use Types::Common -types;
use JSON::MaybeXS;

# Stub sub so Perl can parse it
sub FUNCTION_NAME {}

# Create the Type::Params signature object
my $sig = signature_for FUNCTION_NAME => SIGNATURE_EXPR;

# Extract parameters
my @sig_params = @{ $sig->parameters || [] };
my $pos = 0;
my @params;

# if ($sig->method) {
    # The $self value
    # push @params, {
        # name     => 'arg0',
        # optional => 0,
        # position => $pos++,
    # };
# }

for my $p (@sig_params) {
	push @params, {
		name => "arg$pos",
		optional => $p->optional ? 1 : 0,
		position => $pos,
		type => $p->type->name

lib/App/Test/Generator/SchemaExtractor.pm  view on Meta::CPAN

	# Substitute function name and signature expression
	$payload =~ s/FUNCTION_NAME/$function/g;
	$payload =~ s/SIGNATURE_EXPR/$signature_expr/;

	my $compartment = Safe->new();
	$compartment->permit_only(qw(:base_core :base_mem :base_orig :load));
	if(my $sig = $compartment->reval($payload)) {
		return $sig;
	}

	# Run in an isolated Perl process
	my ($wtr, $rdr, $err) = (undef, undef, gensym);
	local %ENV;

	# Apply memory limit if BSD::Resource is available.
	# This module is Unix-only and not available on Windows,
	# so we guard the call and skip silently if not present.
	eval {
		require BSD::Resource;
		BSD::Resource::setrlimit(
			BSD::Resource::RLIMIT_AS(),
			$MEMORY_LIMIT_BYTES,
			$MEMORY_LIMIT_BYTES
		);
	};
	# Ignore failure — resource limiting is best-effort only

	my $pid = open3($wtr, $rdr, $err, $^X, '-T');

	print $wtr $payload;
	close $wtr;

	local $SIG{ALRM} = sub { croak 'Signature compile timeout' };
	eval { alarm($SIGNATURE_TIMEOUT_SECS) };	# no-op on Windows

	my $stdout = do { local $/; <$rdr> };
	my $stderr = do { local $/; <$err> };

	eval { alarm 0 };

	waitpid($pid, 0);

	if ($stderr && length $stderr) {
		croak "Error compiling signature:\n$stderr";
	}

	return decode_json($stdout);
}

# --------------------------------------------------
# _build_schema_from_meta
#
# Purpose:    Convert the parameter and return type
#             metadata produced by
#             _compile_signature_isolated into a
#             standard schema hashref.
#
# Entry:      $meta - hashref with 'parameters'
#                     arrayref and optional
#                     'returns' hashref, as decoded
#                     from the isolated compile
#                     JSON output.
#
# Exit:       Returns a schema hashref with input,
#             output, style, source, _notes, and
#             _confidence keys.
#
# Side effects: None.
#
# Notes:      Unknown Type::Params type names are
#             mapped to 'string' with a note added
#             and confidence downgraded to 'medium'.
# --------------------------------------------------
sub _build_schema_from_meta {
	my ($self, $meta) = @_;

	my %type_map = (
		Num => 'number',
		Int => 'integer',
		Str => 'string',
		Bool => 'boolean',
		Object  => 'object',
		ArrayRef => 'array',
		HashRef  => 'object',
	);

	my $input;
	my $position = 0;
	my $confidence = 'high';
	my @notes = ('Type::Params detected');

	foreach my $p (@{ $meta->{parameters} || [] }) {
		my $type = $type_map{ $p->{type} } // 'string';

		if (!exists $type_map{$p->{type}}) {
			push @notes, "Unknown type $p->{type}, defaulting to string";
			$confidence = 'medium';
		}

		$input->{"arg$position"} = {
			type => $type,
			position => $position,
			optional => $p->{optional} ? 1 : 0,
		};

		$position++;
	}

	my $output;

	if (my $ret = $meta->{returns}) {
		my $type = $type_map{ $ret->{type} } // 'string';

		if (!exists $type_map{$ret->{type}}) {
			push @notes, "Unknown return type $ret->{type}, defaulting to string";
			$confidence = 'medium';
		}

		$output = {
			type => $type,