App-Test-Generator
view release on metacpan or search on metacpan
lib/App/Test/Generator.pm view on Meta::CPAN
}
if(defined($schema_file)) {
$schema = _load_schema($schema_file);
}
$test_file = $params->{'output_file'};
} else {
# Legacy API
($schema_file, $test_file) = @_;
if(defined($schema_file)) {
$schema = _load_schema($schema_file);
} else {
croak 'Usage: generate(schema_file [, outfile])';
}
}
# Parse the schema file and load into our structures
my %input = %{_load_schema_section($schema, 'input', $schema_file)};
my %output = %{_load_schema_section($schema, 'output', $schema_file)};
my %transforms = %{_load_schema_section($schema, 'transforms', $schema_file)};
my %accessor = %{_load_schema_section($schema, 'accessor', $schema_file)};
my %cases = %{$schema->{cases}} if(exists($schema->{cases}));
my %edge_cases = %{$schema->{edge_cases}} if(exists($schema->{edge_cases}));
my %type_edge_cases = %{$schema->{type_edge_cases}} if(exists($schema->{type_edge_cases}));
$module = $schema->{module} if(exists($schema->{module}) && length($schema->{module}));
$function = $schema->{function} if(exists($schema->{function}));
if(exists($schema->{new})) {
$new = defined($schema->{'new'}) ? $schema->{new} : '_UNDEF';
}
$yaml_cases = $schema->{yaml_cases} if(exists($schema->{yaml_cases}));
$seed = $schema->{seed} if(exists($schema->{seed}));
$iterations = $schema->{iterations} if(exists($schema->{iterations}));
my @edge_case_array = @{$schema->{edge_case_array}} if(exists($schema->{edge_case_array}));
_validate_config($schema);
my %config = %{$schema->{config}} if(exists($schema->{config}));
_normalize_config(\%config);
# Guess module name from config file if not set
if(!$module) {
if($schema_file) {
($module = basename($schema_file)) =~ s/\.(conf|pl|pm|yml|yaml)$//;
$module =~ s/-/::/g;
# Guard against Perl builtin function names being mistaken
# for module names — builtins have no module to load
if(_is_perl_builtin($module)) {
undef $module;
}
}
} elsif($module eq $MODULE_BUILTIN) {
undef $module;
}
if($module && length($module) && ($module ne 'builtin')) {
_validate_module($module, $schema_file);
}
# $module/$function are spliced unescaped into generated test
# source below (use_ok, new_ok, ->$function, $module::$function)
# — reject anything that isn't identifier-shaped before that happens.
_assert_identifier($module, 'module', package => 1) if defined($module) && length($module);
# sensible defaults
$function ||= 'run';
# package => 1: fully-qualified sub names (e.g. DB::DB, a debugger
# hook installed into the DB:: package regardless of its source
# package) are legitimate function names, not just bare identifiers
_assert_identifier($function, 'function', package => 1);
$iterations ||= DEFAULT_ITERATIONS; # default fuzz runs if not specified
$seed = undef if defined $seed && $seed eq ''; # treat empty as undef
# --- YAML corpus support (yaml_cases is filename string) ---
my %yaml_corpus_data;
if (defined $yaml_cases) {
croak("$yaml_cases: $!") if(!-f $yaml_cases);
my $yaml_data = LoadFile(Encode::decode('utf8', $yaml_cases));
if ($yaml_data && ref($yaml_data) eq 'HASH') {
# Validate that the corpus inputs are arrayrefs
# e.g: "FooBar": ["foo_bar"]
# Skip only invalid entries:
for my $expected (keys %{$yaml_data}) {
my $outputs = $yaml_data->{$expected};
unless($outputs && (ref $outputs eq 'ARRAY')) {
carp("$yaml_cases: $expected does not point to an array ref, ignoring");
next;
}
$yaml_corpus_data{$expected} = $outputs;
}
}
}
# Merge Perl %cases and YAML corpus safely
# my %all_cases = (%cases, %yaml_corpus_data);
my %all_cases = (%yaml_corpus_data, %cases);
for my $k (keys %yaml_corpus_data) {
if (exists $cases{$k} && ref($cases{$k}) eq 'ARRAY' && ref($yaml_corpus_data{$k}) eq 'ARRAY') {
$all_cases{$k} = [ @{$yaml_corpus_data{$k}}, @{$cases{$k}} ];
}
}
if(my $hints = delete $schema->{_yamltest_hints}) {
if(my $boundaries = $hints->{boundary_values}) {
push @edge_case_array, @{$boundaries};
}
if(my $invalid = $hints->{invalid}) {
carp('TODO: handle yamltest_hints->invalid');
}
}
# If the schema says the type is numeric, normalize
if ($schema->{type} && $schema->{type} =~ /^(integer|number|float)$/) {
for (@edge_case_array) {
next unless defined $_;
$_ += 0 if Scalar::Util::looks_like_number($_);
}
}
lib/App/Test/Generator.pm view on Meta::CPAN
}
# Ensure properties is always a hashref — if absent or set to
# a non-hash value, replace with a disabled default so that
# downstream code can safely dereference it without checking ref()
$config->{$CONFIG_PROPERTIES_KEY} = { enable => 0 } unless ref($config->{$CONFIG_PROPERTIES_KEY}) eq 'HASH';
}
# --------------------------------------------------
# _valid_type
#
# Determine whether a string is a
# recognised schema field type accepted
# by the generator.
#
# Entry: $type - the type string to validate.
# May be undef.
#
# Exit: Returns 1 if the type is known,
# 0 if the type is unknown or undef.
#
# Notes: The lookup hash is declared with
# 'state' so it is built only once per
# process rather than on every call —
# important since _valid_type is called
# in a loop over all input parameters.
#
# 'int' and 'bool' are accepted as
# aliases for 'integer' and 'boolean'
# respectively, for compatibility with
# schemas generated by external tools
# that use the shorter forms.
# --------------------------------------------------
sub _valid_type {
my $type = $_[0];
# Undef is never a valid type
return 0 unless defined($type);
# Build the lookup table once and cache it for
# the lifetime of the process via 'state'
state %VALID = map { $_ => 1 } qw(
string boolean integer number float
hashref arrayref object int bool any
);
return($VALID{$type} // 0);
}
# --------------------------------------------------
# _assert_identifier
#
# Purpose: Validate that a string is shaped like a
# plain Perl identifier (or, with
# package => 1, a "::"-separated package
# name) before it is spliced into generated
# test source as a bareword, package name,
# method name, or variable name rather than
# a quoted string literal. Schema-derived
# names (module, function, transform names)
# are spliced unescaped at the call sites
# that use this guard, so an unvalidated
# name could otherwise break out of the
# generated source and inject arbitrary
# Perl into a file that L<prove> will run.
#
# Entry: $name - the string to validate.
# $what - short label for the value, used
# only in the croak message.
# %opts - package => 1 allows "::"
# separators in $name.
#
# Exit: Returns $name unchanged on success.
# Croaks if $name is not identifier-shaped.
# --------------------------------------------------
sub _assert_identifier {
my ($name, $what, %opts) = @_;
croak(__PACKAGE__, ": $what is missing or empty")
unless defined($name) && length($name);
my $re = $opts{package}
? qr/^[A-Za-z_]\w*(?:::[A-Za-z_]\w*)*\z/
: qr/^[A-Za-z_]\w*\z/;
croak(__PACKAGE__, ": $what '$name' is not a valid Perl identifier")
unless $name =~ $re;
return $name;
}
# --------------------------------------------------
# _validate_module
#
# Purpose: Check whether the module named in a
# schema can be found in @INC during
# test generation. Optionally also
# attempts to load it if the
# GENERATOR_VALIDATE_LOAD environment
# variable is set.
#
# Entry: $module - the module name to
# check. If undef or
# empty, returns 1
# immediately (builtin
# functions need no
# module).
# $schema_file - path to the schema
# file, used in warning
# messages only.
#
# Exit: Returns 1 if the module was found
# (and loaded, if validation was
# requested).
# Returns 0 if the module was not
# found or failed to load — this is
# non-fatal; generation continues.
# Returns 1 immediately for undef or
# empty $module.
#
# Side effects: Prints to STDERR when TEST_VERBOSE
lib/App/Test/Generator.pm view on Meta::CPAN
# Skip non-arrayref values — mixed hashes are allowed by callers
next unless ref($aref) eq 'ARRAY';
# Render each array element via perl_quote so strings are
# properly quoted and numbers are left unquoted
my $vals = join(', ', map { perl_quote($_) } @{$aref});
# Use "\t" rather than a literal tab for clarity
push @entries, "\t" . perl_quote($k) . " => [ $vals ]";
}
return join(",\n", @entries);
}
# --------------------------------------------------
# _has_positions
#
# Purpose: Determine whether any field in an input
# spec hashref declares a positional argument
# via the 'position' key.
#
# Entry: $input_spec - the input section of a parsed
# schema, expected to be a hashref whose values
# are themselves hashrefs containing field specs.
# May be undef or a non-hash ref.
#
# Exit: Returns 1 if any field has a defined
# 'position' key, 0 otherwise.
#
# Notes: Returns 0 immediately for undef or non-hash
# input rather than throwing — callers use the
# return value as a boolean and do not expect
# exceptions from this function.
# --------------------------------------------------
sub _has_positions {
my $input_spec = $_[0];
# Guard against undef or non-hash input — keys %$undef would throw
return 0 unless defined($input_spec) && ref($input_spec) eq 'HASH';
for my $field (keys %{$input_spec}) {
# Only examine fields whose spec is a hashref — scalar specs
# (e.g. input: { type: string }) cannot have positions
next unless ref($input_spec->{$field}) eq 'HASH';
# Return immediately on first match — no need to scan further
return 1 if defined $input_spec->{$field}{position};
}
# No positional arguments found in any field
return 0;
}
# --------------------------------------------------
# q_wrap
#
# Purpose: Wrap a string in the most readable
# q{} form that does not require escaping,
# falling back to single-quoted form with
# escaped apostrophes if no delimiter is
# available.
#
# Entry: $s - the string to wrap. May be undef.
# Exit: Returns a Perl source-code fragment that
# evaluates to the original string value,
# or the string 'undef' if $s is undef.
#
# Notes: index() returns -1 when not found and
# any value >= 0 when found, including 0
# for a delimiter at the start of the
# string. We compare against $INDEX_NOT_FOUND
# to make this boundary explicit and to
# prevent off-by-one mutation survivors.
# See GitHub issue #1.
# --------------------------------------------------
sub q_wrap {
my $s = $_[0];
croak('q_wrap: argument must be a plain string, not a reference') if ref($s);
# Return empty string for undef — this function is a low-level
# string quoter only. Callers that need the Perl literal 'undef'
# for undefined values should use perl_quote() instead, which
# handles the undef -> 'undef' semantic conversion correctly.
# Returning '' here preserves the original behaviour and avoids
# injecting the bare word 'undef' into contexts that expect a
# quoted string value.
return "''" unless defined $s;
# Try bracket-form q{} delimiters first — most readable
for my $p (@Q_BRACKET_PAIRS) {
my ($l, $r) = @{$p};
# Only use this bracket pair if neither bracket
# appears in the string — both must be checked
return "q$l$s$r" unless $s =~ /\Q$l\E|\Q$r\E/;
}
# Try single-character delimiters in preference order
for my $d (@Q_SINGLE_DELIMITERS) {
# index() returns $INDEX_NOT_FOUND (-1) when not found.
# Must use != $INDEX_NOT_FOUND rather than > 0 since
# the delimiter may legitimately appear at position 0
return "q$d$s$d" if index($s, $d) == $INDEX_NOT_FOUND;
}
# Last resort — single-quoted string with escaped apostrophes
(my $esc = $s) =~ s/'/\\'/g;
return "'$esc'";
}
# --------------------------------------------------
# perl_sq
#
# Purpose: Escape a string for safe inclusion
# inside a single-quoted Perl string
# literal in generated test code.
#
# Entry: $s - the string to escape.
# Exit: Returns the escaped string, or an
# empty string if $s is undef.
#
# Notes: NUL byte replacement produces the
# two-character sequence \0 which is
# only correct when the result is used
# inside a double-quoted string context
# in the generated test.
#
# The \b substitution (backspace) is
# intentionally omitted — in Perl regex
# context \b means word boundary, not
# backspace, so substituting it here
# would corrupt strings containing word
# boundaries.
# --------------------------------------------------
sub perl_sq {
my $s = $_[0];
croak('perl_sq: argument must be a plain string, not a reference') if ref($s);
# Return empty string for undef — callers that need
# 'undef' literal should use perl_quote instead
return '' unless defined $s;
# Escape backslashes first so later substitutions
# don't double-escape already-escaped sequences
$s =~ s/\\/\\\\/g;
# Escape apostrophes so they don't terminate the
# surrounding single-quoted string literal
$s =~ s/'/\\'/g;
# Escape common control characters to their
# printable two-character escape sequences
$s =~ s/\n/\\n/g;
$s =~ s/\r/\\r/g;
$s =~ s/\t/\\t/g;
$s =~ s/\f/\\f/g;
# Replace NUL bytes with \0 — valid only in
# double-quoted string context in generated code
$s =~ s/\0/\\0/g;
return $s;
}
=head2 perl_quote
Convert any Perl value into a source-code fragment that reproduces that value
when evaluated in a generated test file.
=head3 Arguments
=over 4
=item * C<$v>
Any Perl value. May be undef, a scalar, an arrayref, a Regexp, or a blessed
object. All types are handled — undef becomes C<'undef'>, the strings
C<'true'>/C<'false'> become the Perl boolean constants C<!!1>/C<!!0>,
numbers are unquoted, other strings are single-quoted, arrayrefs recurse,
Regexps become C<qr{...}>, and anything else (including hashrefs and
blessed objects) falls through to C<render_fallback>.
=back
=head3 API specification
=head4 input
{ v => { type => 'any', optional => 1 } }
=head4 output
{ type => 'string' }
=cut
sub perl_quote {
my ($v) = @_;
return _perl_quote($v, 0);
}
sub _perl_quote {
my ($v, $depth) = @_;
no warnings 'recursion'; ## no critic (TestingAndDebugging::ProhibitNoWarnings)
croak('perl_quote: structure too deeply nested (circular reference?)') if $depth > 100;
# Undef produces the Perl literal 'undef'
return 'undef' unless defined $v;
# Convert YAML boolean string literals to Perl
# boolean constants so they survive round-tripping
return '!!1' if $v eq 'true';
lib/App/Test/Generator.pm view on Meta::CPAN
# Guard: skip transforms with no input or with the
# YAML scalar 'undef' as their input — these have no
# generator and cannot produce meaningful properties
if(!defined($input_spec) ||
(!ref($input_spec) && $input_spec eq 'undef')) {
next;
}
# Guard: skip transforms whose input is not a hashref —
# must come before the helper calls below so we never
# pass a non-hash to _detect_transform_properties or
# _process_custom_properties
next unless ref($input_spec) eq 'HASH';
# Default output spec to empty hash so _STATUS lookups
# below are always safe regardless of schema content
my $output_spec = $transform->{output} // {};
# Detect automatic properties from the transform spec
# (range constraints, type preservation, definedness)
my @detected_props = _detect_transform_properties(
$transform_name,
$input_spec,
$output_spec
);
# Process any custom properties defined in the schema
my @custom_props = ();
if(exists($transform->{properties}) &&
ref($transform->{properties}) eq 'ARRAY') {
@custom_props = _process_custom_properties(
$transform->{properties},
$function,
$module,
$input_spec,
$output_spec,
$new
);
}
# Combine auto-detected and custom properties into one list
my @all_props = (@detected_props, @custom_props);
# Skip this transform if no properties were produced —
# nothing useful to render into the generated test
next unless @all_props;
# Build the LectroTest generator specification string,
# one entry per input field that has a generator
my @generators;
my @var_names;
for my $field (sort keys %{$input_spec}) {
my $spec = $input_spec->{$field};
# Skip non-hashref field specs — scalar types
# like 'string' have no generator sub-structure
next unless ref($spec) eq 'HASH';
# $field is spliced unescaped into the generated
# LectroTest generator spec by
# _schema_to_lectrotest_generator() — reject anything
# that isn't identifier-shaped first.
_assert_identifier($field, 'input field name');
my $gen = _schema_to_lectrotest_generator($field, $spec);
if(defined($gen) && length($gen)) {
push @generators, $gen;
push @var_names, $field;
}
}
my $gen_spec = join(', ', @generators);
# Build the call expression for the function under test.
# Note: property tests always construct a fresh object
# via new_ok() with no constructor arguments, regardless
# of what $new holds in the caller — the intent here is
# to test the method in isolation, not with specific
# construction state.
my $call_code;
if($module && defined($new)) {
# OO mode — construct a fresh object for each trial
$call_code = "my \$obj = new_ok('$module');";
$call_code .= "\$obj->$function";
} elsif($module && $module ne $MODULE_BUILTIN) {
# Functional mode with a named module
$call_code = "$module\::$function";
} else {
# Builtin or unqualified function call
$call_code = $function;
}
# Build the argument list, respecting positional order
# if the input spec declares positions
my @args;
if(_has_positions($input_spec)) {
# Sort fields by declared position so the generated
# call passes arguments in the correct order
my @sorted = sort {
$input_spec->{$a}{position} <=>
$input_spec->{$b}{position}
} keys %{$input_spec};
@args = map { "\$$_" } @sorted;
} else {
# No positions — use alphabetical order from @var_names
@args = map { "\$$_" } @var_names;
}
my $args_str = join(', ', @args);
# Concatenate all property check expressions with &&
# so the generated property block passes only when
# every check holds
my @checks = map { $_->{code} } @all_props;
my $property_checks = join(" &&\n\t", @checks);
# Determine expected behaviour from output _STATUS.
# Note: the schema convention uses 'WARNS' not 'WARN'
my $should_die = ($output_spec->{'_STATUS'} // '') eq 'DIES';
lib/App/Test/Generator.pm view on Meta::CPAN
my $min = $spec->{'min'};
my $max = $spec->{'max'};
if(!defined($min) && !defined($max)) {
# Unconstrained — symmetric range around zero
return "$field_name <- Float(sized => sub { rand($DEFAULT_GENERATOR_RANGE) - $DEFAULT_GENERATOR_RANGE / 2 })";
} elsif(!defined($min)) {
# Only max defined — choose range based on sign of max
if($max == $ZERO_BOUNDARY) {
# max=0: negative numbers only
return "$field_name <- Float(sized => sub { -rand($DEFAULT_GENERATOR_RANGE) })";
} elsif($max > $ZERO_BOUNDARY) {
# Positive max: generate 0 to max
return "$field_name <- Float(sized => sub { rand($max) })";
} else {
# Negative max: generate from (max - range) to max
return "$field_name <- Float(sized => sub { ($max - $DEFAULT_GENERATOR_RANGE) + rand($DEFAULT_GENERATOR_RANGE + $max) })";
}
} elsif(!defined($max)) {
# Only min defined — choose range based on sign of min
if($min == $ZERO_BOUNDARY) {
# min=0: positive numbers only
return "$field_name <- Float(sized => sub { rand($DEFAULT_GENERATOR_RANGE) })";
} elsif($min > $ZERO_BOUNDARY) {
# Positive min: generate min to min + range
return "$field_name <- Float(sized => sub { $min + rand($DEFAULT_GENERATOR_RANGE) })";
} else {
# Negative min: generate from min to min + range
return "$field_name <- Float(sized => sub { $min + rand(-$min + $DEFAULT_GENERATOR_RANGE) })";
}
} else {
# Both min and max defined — validate then generate
my $range = $max - $min;
if($range <= $ZERO_BOUNDARY) {
carp "Invalid range for '$field_name': min=$min, max=$max";
# Return undef rather than emitting a degenerate
# generator that would silently produce wrong values
return;
}
return "$field_name <- Float(sized => sub { $min + rand($range) })";
}
}
# --------------------------------------------------
# String generator
# --------------------------------------------------
if($type eq 'string') {
my $min_len = $spec->{'min'} // 0;
my $max_len = $spec->{'max'} // $DEFAULT_MAX_STRING_LEN;
# If a regex pattern is declared, delegate to
# Data::Random::String::Matches for pattern-aware generation
if(defined($spec->{'matches'})) {
my $pattern = $spec->{'matches'};
# Compile the pattern safely rather than splicing the raw
# string into qr/$pattern/ — the raw form lets a pattern
# containing an unescaped '/' break out of the qr//
# delimiter and inject arbitrary Perl into the generated
# test. regexp_pattern() decomposes the already-compiled
# Regexp object back into pattern text that is guaranteed
# to be a self-contained regex body, safe to re-embed.
my $compiled = ref($pattern) eq 'Regexp' ? $pattern : eval { qr/$pattern/ };
if($@ || !defined($compiled)) {
carp "Invalid matches pattern '$pattern' for field '$field_name': $@";
return "$field_name <- String(length => [$min_len, $max_len])";
}
my ($pat, $mods) = regexp_pattern($compiled);
my $safe_re = "qr{$pat}" . ($mods // '');
if(defined($spec->{'max'})) {
return "$field_name <- Gen { Data::Random::String::Matches->create_random_string({ regex => $safe_re, length => $spec->{'max'} }) }";
} elsif(defined($spec->{'min'})) {
return "$field_name <- Gen { Data::Random::String::Matches->create_random_string({ regex => $safe_re, length => $spec->{'min'} }) }";
} else {
return "$field_name <- Gen { Data::Random::String::Matches->create_random_string({ regex => $safe_re }) }";
}
}
return "$field_name <- String(length => [$min_len, $max_len])";
}
# --------------------------------------------------
# Boolean generator
# --------------------------------------------------
if($type eq 'boolean') {
return "$field_name <- Bool";
}
# --------------------------------------------------
# Arrayref generator
# --------------------------------------------------
if($type eq 'arrayref') {
my $min_size = $spec->{'min'} // 0;
my $max_size = $spec->{'max'} // $DEFAULT_MAX_COLLECTION_SIZE;
return "$field_name <- List(Int, length => [$min_size, $max_size])";
}
# --------------------------------------------------
# Hashref generator
# LectroTest has no built-in Hash generator so we
# use Elements over a pre-built list of hashrefs
# --------------------------------------------------
if($type eq 'hashref') {
my $min_keys = $spec->{'min'} // 0;
my $max_keys = $spec->{'max'} // $DEFAULT_MAX_COLLECTION_SIZE;
return "$field_name <- Elements(map { my \%h; for (1..\$_) { \$h{'key'.\$_} = \$_ }; \\\%h } $min_keys..$max_keys)";
}
# --------------------------------------------------
# Unknown type — fall back to String with a warning
# --------------------------------------------------
carp "Unknown type '$type' for '$field_name' LectroTest generator, using String";
return "$field_name <- String";
}
# --------------------------------------------------
# _is_numeric_transform
lib/App/Test/Generator.pm view on Meta::CPAN
}
if(defined($output_spec->{'max'})) {
my $max = $output_spec->{'max'};
push @properties, {
name => 'max_constraint',
code => "defined(\$result) && looks_like_number(\$result) && \$result <= $max",
};
}
# Heuristic: transforms named 'positive' (case-insensitive)
# imply a non-negative result constraint
if($transform_name =~ /$TRANSFORM_POSITIVE_PATTERN/i) {
push @properties, {
name => 'non_negative',
code => "defined(\$result) && looks_like_number(\$result) && \$result >= 0",
};
}
}
# --------------------------------------------------
# Property 2: Specific value output
# --------------------------------------------------
if(defined($output_spec->{'value'})) {
my $expected = $output_spec->{'value'};
# Numeric refs use == for comparison; scalars use eq
# via perl_quote to produce the correct quoted literal
push @properties, {
name => 'exact_value',
code => ref($expected)
? "\$result == $expected"
: "\$result eq " . perl_quote($expected),
};
}
# --------------------------------------------------
# Property 3: String length constraints
# --------------------------------------------------
if(_is_string_transform($input_spec, $output_spec)) {
if(defined($output_spec->{'min'})) {
push @properties, {
name => 'min_length',
code => "length(\$result) >= $output_spec->{'min'}",
};
}
if(defined($output_spec->{'max'})) {
push @properties, {
name => 'max_length',
code => "length(\$result) <= $output_spec->{'max'}",
};
}
if(defined($output_spec->{'matches'})) {
my $pattern = $output_spec->{'matches'};
# See the matching comment in _schema_to_lectrotest_generator —
# compile first and re-embed via regexp_pattern() rather than
# splicing the raw string into qr/$pattern/, which would let
# an unescaped '/' break out of the delimiter.
my $compiled = ref($pattern) eq 'Regexp' ? $pattern : eval { qr/$pattern/ };
if($@ || !defined($compiled)) {
carp "Invalid matches pattern '$pattern' for transform '$transform_name': $@";
} else {
my ($pat, $mods) = regexp_pattern($compiled);
my $safe_re = "qr{$pat}" . ($mods // '');
push @properties, {
name => 'pattern_match',
code => "\$result =~ $safe_re",
};
}
}
}
# --------------------------------------------------
# Property 4: Type preservation
# --------------------------------------------------
if(_same_type($input_spec, $output_spec)) {
my $type = _get_dominant_type($output_spec);
# Only emit a numeric_type check for numeric types —
# string and other types have no equivalent simple check
if($type eq 'number' || $type eq 'integer' || $type eq 'float') {
push @properties, {
name => 'numeric_type',
code => 'looks_like_number($result)',
};
}
}
# --------------------------------------------------
# Property 5: Definedness
# --------------------------------------------------
# Emit a defined() check for all transforms except those
# whose output type is explicitly 'undef' — those are
# expected to return nothing
unless(($output_spec->{'type'} // '') eq 'undef') {
push @properties, {
name => 'defined',
code => 'defined($result)',
};
}
return @properties;
}
# --------------------------------------------------
# _process_custom_properties
#
# Purpose: Process the 'properties' array from a
# transform definition, resolving each
# entry to either a named builtin property
# (looked up from _get_builtin_properties)
# or a custom property with inline code.
#
# Entry: $properties_spec - arrayref of property
# definitions from the
# schema. Each element
# is either a string
# (builtin name) or a
( run in 1.141 second using v1.01-cache-2.11-cpan-788537b7465 )