App-Test-Generator
view release on metacpan or search on metacpan
lib/App/Test/Generator/SchemaExtractor.pm view on Meta::CPAN
my $returns_desc = $1;
$returns_desc =~ s/^\s+|\s+$//g;
$self->_log(" OUTPUT: Found Returns section: $returns_desc");
# Try to infer type from description
if ($returns_desc =~ /\b(string|text)\b/i) {
$output->{type} = 'string';
} elsif ($returns_desc =~ /\b(integer|int|count)\b/i) {
$output->{type} = 'integer';
} elsif ($returns_desc =~ /\b(float|decimal|number)\b/i) {
$output->{type} = 'number';
} elsif ($returns_desc =~ /\b(boolean|true|false)\b/i) {
$output->{type} = 'boolean';
} elsif ($returns_desc =~ /\b(array|list)\b/i) {
$output->{type} = 'arrayref';
} elsif ($returns_desc =~ /\b(hash|hashref|dictionary)\b/i) {
$output->{type} = 'hashref';
} elsif ($returns_desc =~ /\b(object|instance)\b/i) {
$output->{type} = 'object';
} elsif ($returns_desc =~ /\bundef\b/i) {
$output->{type} = 'undef';
}
# Look for specific values
if ($returns_desc =~ /\b1\s+(?:on\s+success|if\s+successful)\b/i) {
$output->{value} = 1;
if(defined($output->{'type'}) && ($output->{type} eq 'scalar')) {
$output->{type} = 'boolean';
} else {
$output->{type} ||= 'boolean';
}
$self->_log(" OUTPUT: Returns 1 on success");
} elsif ($returns_desc =~ /\b0\s+(?:on\s+failure|if\s+fail)\b/i) {
$output->{alt_value} = 0;
} elsif ($returns_desc =~ /dies\s+on\s+(?:error|failure)/i) {
$output->{_STATUS} = 'LIVES';
$self->_log(' OUTPUT: Should not die on success');
}
if ($returns_desc =~ /\b(true|false)\b/i) {
$output->{type} ||= 'boolean';
}
if ($returns_desc =~ /\bundef\b/i) {
$output->{optional} = 1;
}
}
# Pattern 2: Inline "returns X"
if((!$output->{type}) && ($pod =~ /returns?\s+(?:an?\s+)?(\w+)/i)) {
my $type = lc($1);
$type = 'boolean' if $type =~ /^(true|false|bool)$/;
# Skip if it's just a number (like "returns 1")
$type = 'integer' if $type eq 'int';
$type = 'number' if $type =~ /^(num|float)$/;
$type = 'arrayref' if $type eq 'array';
$type = 'hashref' if $type eq 'hash';
if($type =~ /^\d+$/) {
if($type eq '1' || $type eq '0') {
# Try hard to guess if the result is a boolean
if($pod =~ /1 on success.+0 (on|if) /i) {
$type = 'boolean';
} elsif($pod =~ /return 0 .+ 1 on success/) {
$type = 'boolean';
} else {
$type = 'integer';
}
} else {
$type = 'integer';
}
}
$type = 'arrayref' if !$type && $pod =~ /returns?\s+.+\slist\b/i;
# $output->{type} = $type if $type && $type !~ /^\d+$/;
if ($VALID_OUTPUT_TYPES{$type}) {
$output->{type} = $type;
$self->_log(" OUTPUT: Inferred type from POD: $type");
} else {
$self->_log(" OUTPUT: POD return type '$type' is not a valid type, ignoring");
}
}
}
}
# --------------------------------------------------
# _extract_defaults_from_pod
#
# Purpose: Extract default values for parameters
# from POD documentation using multiple
# pattern strategies.
#
# Entry: $pod - POD string for the method.
# May be undef or empty.
#
# Exit: Returns a hashref of parameter name
# to cleaned default value. Returns an
# empty hashref if no POD is provided
# or no defaults are found.
#
# Side effects: None.
#
# Notes: Three strategies are tried: (1) lines
# containing 'Default:' or 'Defaults to:',
# (2) lines containing 'Optional, default',
# (3) inline $name - type, default value
# format. Parameter names are inferred
# by scanning backwards from the default
# phrase to the nearest $variable.
# --------------------------------------------------
sub _extract_defaults_from_pod {
my ($self, $pod) = @_;
return {} unless $pod;
my %defaults;
# Pattern 1: Default: 'value' or Defaults to: 'value'
while ($pod =~ /(?:Default(?:s? to)?|default(?:s? to)?)[:]\s*([^\n\r]+)/gi) {
my $default_text = $1;
my $match_pos = pos($pod);
lib/App/Test/Generator/SchemaExtractor.pm view on Meta::CPAN
# Side effects: None.
# --------------------------------------------------
sub _generate_notes {
my ($self, $params) = @_;
my @notes;
foreach my $param (keys %$params) {
my $p = $params->{$param};
unless ($p->{type}) {
push @notes, "$param: type unknown - please review - will set to 'string' as a default";
}
unless (defined $p->{optional}) {
push @notes, "$param: optional status unknown";
# Don't automatically set - let it be undef if we don't know
}
}
return \@notes;
}
# --------------------------------------------------
# _set_defaults
#
# Purpose: Apply default type values to any
# parameters in a schema mode (input
# or output) whose type was not set
# during analysis, setting them to
# 'string' as a conservative fallback.
#
# Entry: $schema - the schema hashref being
# built by _analyze_method.
# $mode - either 'input' or 'output'.
#
# Exit: Returns nothing. Modifies $schema in
# place by setting type => 'string' on
# any parameter that lacks a type, and
# downgrading input confidence to 'low'.
#
# Side effects: Logs type defaulting to stdout when
# verbose is set.
#
# Notes: Called after all analysis is complete
# so that genuine type unknowns can be
# distinguished from analysis gaps.
# --------------------------------------------------
sub _set_defaults {
my ($self, $schema, $mode) = @_;
my $params = $schema->{$mode};
foreach my $param (keys %$params) {
my $p = $params->{$param};
next unless(ref($p) eq 'HASH');
unless ($p->{type}) {
$self->_log(" DEBUG {$mode}{$param}: Setting to 'string' as a default");
$p->{'type'} = 'string';
$schema->{_confidence}{$mode}->{level} = 'low'; # Setting a default means it's a guess
}
}
}
# --------------------------------------------------
# _analyze_relationships
#
# Purpose: Detect inter-parameter relationships
# in a method's source code, including
# mutually exclusive parameters, required
# groups, conditional requirements,
# dependencies, and value-based
# constraints.
#
# Entry: $method - method hashref containing
# at minimum a 'body' key
# with the source string.
#
# Exit: Returns an arrayref of relationship
# hashrefs. Returns an empty arrayref
# if no parameters or no relationships
# are found.
#
# Side effects: Logs detections to stdout when
# verbose is set.
#
# Notes: Parameter names are extracted from
# the my (...) = @_ pattern only —
# shift-style parameters are not
# currently analysed for relationships.
# --------------------------------------------------
sub _analyze_relationships {
my ($self, $method) = @_;
my $code = $method->{body};
my @relationships;
# Extract all parameter names from the method
my @param_names;
if ($code =~ /my\s*\(\s*\$\w+\s*,\s*(.+?)\)\s*=\s*\@_/s) {
my $params = $1;
@param_names = $params =~ /\$(\w+)/g;
}
return [] unless @param_names;
# Detect mutually exclusive parameters
push @relationships, @{$self->_detect_mutually_exclusive($code, \@param_names)};
# Detect required groups (OR logic)
push @relationships, @{$self->_detect_required_groups($code, \@param_names)};
# Detect conditional requirements (IF-THEN)
push @relationships, @{$self->_detect_conditional_requirements($code, \@param_names)};
# Detect dependencies
push @relationships, @{$self->_detect_dependencies($code, \@param_names)};
# Detect value-based constraints
push @relationships, @{$self->_detect_value_constraints($code, \@param_names)};
lib/App/Test/Generator/SchemaExtractor.pm view on Meta::CPAN
my $filename = "$self->{output_dir}/${method_name}.yml";
# Configure YAML::XS to not quote numeric strings
local $YAML::XS::QuoteNumericStrings = 0;
# Extract package name for module field
my $package_name = '';
if ($self->{_document}) {
my $package_stmt = $self->{_document}->find_first('PPI::Statement::Package');
$package_name = $package_stmt ? $package_stmt->namespace : '';
$self->{_package_name} //= $package_name;
}
# Clean up schema for output - use the format expected by App::Test::Generator::Template
my $output = {
function => $method_name,
module => $package_name,
config => {
close_stdin => 0,
dedup => 1,
test_nuls => 0,
test_undef => 0,
test_empty => 1,
test_non_ascii => 0,
test_security => 0
}
};
# Process input parameters with advanced type handling
if($schema->{'input'}) {
if(scalar(keys %{$schema->{'input'}})) {
$output->{'input'} = {};
foreach my $param_name (keys %{$schema->{'input'}}) {
my $param = $schema->{'input'}{$param_name};
if($param->{name}) {
my $name = delete $param->{name};
if($name ne $param_name) {
# Sanity check
croak("BUG: Parameter name - expected $param_name, got $name");
}
}
my $cleaned_param = $self->_serialize_parameter_for_yaml($param);
$output->{'input'}{$param_name} = $cleaned_param;
}
} else {
delete $output->{input};
}
}
# Process output
if($schema->{'output'} && (scalar(keys %{$schema->{'output'}}))) {
if((ref($schema->{output}{_error_handling}) eq 'HASH') && (scalar(keys %{$schema->{output}{_error_handling}}) == 0)) {
delete $schema->{output}{_error_handling};
}
$output->{'output'} = $schema->{'output'};
}
if($schema->{'output'}{'type'} && ($schema->{'output'}{'type'} eq 'scalar')) {
$schema->{'output'}{'type'} = 'string';
$schema->{_confidence}{output}->{level} = 'low'; # A guess
}
# Add 'new' field if object instantiation is needed
if ($schema->{new}) {
# TODO: consider allowing parent class packages up the ISA chain
if(ref($schema->{new}) || ($schema->{new} eq $package_name)) {
$output->{new} = $schema->{new} eq $package_name ? undef : $schema->{'new'};
} else {
$self->_log(" NEW: Don't use $schema->{new} for object insantiation");
delete $schema->{new};
delete $output->{new};
}
}
if(!defined($schema->{_confidence}{input}->{level})) {
$schema->{_confidence}{input} = $self->_calculate_input_confidence($schema->{input});
}
if(!defined($schema->{_confidence}{output}->{level})) {
$schema->{_confidence}{output} = $self->_calculate_output_confidence($schema->{output});
}
# Add relationships if detected
if ($schema->{relationships} && @{$schema->{relationships}}) {
$output->{relationships} = $schema->{relationships};
}
if($schema->{accessor} && scalar(keys %{$schema->{accessor}})) {
$output->{accessor} = $schema->{accessor};
}
open my $fh, '>', $filename;
print $fh YAML::XS::Dump($output);
print $fh $self->_generate_schema_comments($schema, $method_name);
close $fh;
my $rel_info = $schema->{relationships} ?
' [' . scalar(@{$schema->{relationships}}) . ' relationships]' : '';
$self->_log(" Wrote: $filename (input confidence: $schema->{_confidence}{input}->{level})" .
($schema->{new} ? " [requires: $schema->{new}]" : '') . $rel_info);
}
# --------------------------------------------------
# _generate_schema_comments
#
# Purpose: Generate the YAML comment block
# appended to the end of each written
# schema file, containing provenance,
# confidence levels, parameter type
# notes, relationship summaries, and
# warnings about types requiring
# special test setup.
#
# Entry: $schema - the schema hashref as
# built by _analyze_method.
# $method_name - the method name string,
# used in the fuzz
# command hint.
#
# Exit: Returns a string of YAML comment lines
# beginning with a blank line and ending
( run in 0.749 second using v1.01-cache-2.11-cpan-39bf76dae61 )