File Coverage

File:	blib/lib/App/Test/Generator.pm
Coverage:	81.5%

line	stmt	bran	cond	sub	time	code
1						package App::Test::Generator;
2
3						# TODO: Test validator from Params::Validate::Strict 0.16
4						# TODO: $seed should be passed to Data::Random::String::Matches
5						# TODO: positional args - when config_undef is set, see what happens when not all args are given
6						# TODO: The Dup and TER1/2/3 columns should be moved from the Mutation table
7						# to a new table called Metrics. Add Halstead and McCabes metrics to
8						# this new Metrics table. Include links to the definitions of TER1/2/3,
9						# Halstead and McCabes metrics, perhaps from Wikipedia
10
11	22 22			22	1204340 43	use 5.036;
12
13	22 22 22			22	39 18 179	use strict;
14	22 22 22			22	34 18 409	use warnings;
15	22 22 22			22	2284 71827 64	use autodie qw(:all);
16
17	22 22 22			22	115829 2280 45	use utf8;
18	22 22 22			22	3681 10790 55	use open qw(:std :encoding(UTF-8));
19
20	22 22 22			22	119727 28 383	use App::Test::Generator::Template;
21	22 22 22			22	51 15 612	use Carp qw(carp croak confess);
22	22 22 22			22	7082 622962 367	use Config::Abstraction 0.36;
23	22 22 22			22	2640 29534 597	use Data::Dumper;
24	22 22 22			22	47 20 352	use Data::Section::Simple;
25	22 22 22			22	37 17 517	use File::Basename qw(basename);
26	22 22 22			22	32 18 226	use File::Spec;
27	22 22 22			22	4737 174605 652	use Module::Load::Conditional qw(check_install can_load);
28	22 22 22			22	54 15 364	use Params::Get;
29	22 22 22			22	39 159 280	use Params::Validate::Strict 0.36;
30	22 22 22			22	35 15 303	use Readonly;
31	22 22 22			22	37 15 1002	use Readonly::Values::Boolean;
32	22 22 22			22	44 15 396	use Scalar::Util qw(looks_like_number);
33	22 22 22			22	49 45 1314	use re 'regexp_pattern';
34	22 22 22			22	4661 165587 375	use Template;
35	22 22 22			22	2957 21063 578	use YAML::XS qw(LoadFile);
36
37	22 22 22			22	48 18 49294	use Exporter 'import';
38
39						our @EXPORT_OK = qw(generate);
40
41						our $VERSION = '0.46';
42
43						Readonly my $DEFAULT_ITERATIONS => 30;
44						Readonly my $DEFAULT_PROPERTY_TRIALS => 1000;
45
46						# Hash for O(1) lookup rather than a list needing grep O(n)
47						Readonly my %VALID_CONFIG_KEYS => map { $_ => 1 } qw(
48						test_nuls test_undef test_empty test_non_ascii
49						dedup properties close_stdin test_security timeout
50						);
51
52						# --------------------------------------------------
53						# Delimiter pairs tried in order when wrapping a
54						# string with q{} â€” bracket forms are preferred as
55						# they are most readable in generated test code
56						# --------------------------------------------------
57						Readonly my @Q_BRACKET_PAIRS => (
58						['{', '}'],
59						['(', ')'],
60						['[', ']'],
61						['<', '>'],
62						);
63
64						# --------------------------------------------------
65						# Single-character delimiters tried when no bracket
66						# pair is usable â€” each is tried in order and the
67						# first one not present in the string is used.
68						# The # character is last since it starts comments
69						# in many contexts and is least readable
70						# --------------------------------------------------
71						Readonly my @Q_SINGLE_DELIMITERS => (
72						'~', '!', '%', '^', '=', '+', ':', ',', ';', '\|', '/', '#'
73						);
74
75						# --------------------------------------------------
76						# Sentinel returned by index() when the search
77						# string is not found â€” used to make the >= 0
78						# boundary check self-documenting and to prevent
79						# NumericBoundary mutants from surviving
80						# --------------------------------------------------
81						Readonly my $INDEX_NOT_FOUND => -1;
82
83						# --------------------------------------------------
84						# Readonly constants for schema validation
85						# --------------------------------------------------
86						Readonly my $CONFIG_PROPERTIES_KEY => 'properties';
87						Readonly my $LEGACY_PERL_KEY_1 => '$module';
88						Readonly my $LEGACY_PERL_KEY_2 => 'our $module';
89						Readonly my $SOURCE_KEY => '_source';
90
91						# --------------------------------------------------
92						# Readonly constants for render_hash key detection
93						# --------------------------------------------------
94						Readonly my $KEY_MATCHES => 'matches';
95						Readonly my $KEY_NOMATCH => 'nomatch';
96
97						# --------------------------------------------------
98						# Reserved module name indicating a Perl builtin
99						# function rather than a CPAN or user module
100						# --------------------------------------------------
101						Readonly my $MODULE_BUILTIN => 'builtin';
102
103						# --------------------------------------------------
104						# Regex pattern matched against transform names to
105						# detect the positive/non-negative idempotence
106						# heuristic in _detect_transform_properties
107						# --------------------------------------------------
108						Readonly my $TRANSFORM_POSITIVE_PATTERN => 'positive';
109
110						# --------------------------------------------------
111						# Default type assumed for schema fields that declare
112						# no explicit type â€” used in generator selection and
113						# dominant-type detection
114						# --------------------------------------------------
115						Readonly my $DEFAULT_FIELD_TYPE => 'string';
116
117						# --------------------------------------------------
118						# Default range used by the LectroTest float/integer
119						# generators when no min or max constraint is given.
120						# Chosen to provide a useful spread without producing
121						# values so large they overflow downstream arithmetic.
122						# --------------------------------------------------
123						Readonly my $DEFAULT_GENERATOR_RANGE => 1000;
124
125						# --------------------------------------------------
126						# Default upper bound on the number of elements in
127						# generated arrayrefs and hashrefs when no max is
128						# declared in the schema.
129						# --------------------------------------------------
130						Readonly my $DEFAULT_MAX_COLLECTION_SIZE => 10;
131
132						# --------------------------------------------------
133						# Default upper bound on generated string length
134						# when no max is declared in the schema.
135						# --------------------------------------------------
136						Readonly my $DEFAULT_MAX_STRING_LEN => 100;
137
138						# --------------------------------------------------
139						# Sentinel for the zero boundary used in float
140						# generator selection â€” comparing min/max against
141						# this constant makes the boundary intent explicit
142						# and prevents NumericBoundary mutants from surviving.
143						# --------------------------------------------------
144						Readonly my $ZERO_BOUNDARY => 0;
145
146						# --------------------------------------------------
147						# Environment variable names used to control verbose
148						# output and optional load validation in
149						# _validate_module. Centralised here so they are
150						# easy to find and consistent across the codebase.
151						# --------------------------------------------------
152						Readonly my $ENV_TEST_VERBOSE => 'TEST_VERBOSE';
153						Readonly my $ENV_GENERATOR_VERBOSE => 'GENERATOR_VERBOSE';
154						Readonly my $ENV_VALIDATE_LOAD => 'GENERATOR_VALIDATE_LOAD';
155
156 - 1593						=head1 NAME App::Test::Generator - Fuzz Testing, Mutation Testing, LCSAJ Metrics and Test Dashboard for Perl modules =head1 VERSION Version 0.46 =head1 SYNOPSIS C<App::Test::Generator> is a suite to help the testing of CPAN modules. It consists of 6 subsystems: =over 4 =item * Fuzz Tester =item * Mutation Testing =item * LCSAJ Metrics =item * Test Dashboard =item * Benchmark Generation =item * Workflow Deployment =back From the command line: # Takes the formal definition of a routine, creates tests against that routine, and runs the test fuzz-harness-generator -r t/conf/abs.yml # Attempt to create a formal definition from a routine package, then run tests against that formal definition # This is the holy grail of test generation, a set of tests is automatically created directly from the source code, extract-schemas lib/App/Test/Generator/Sample/Module.pm && fuzz-harness-generator -r schemas/greet.yml # Fuzz a module and keep the corpus bounded: trim to the minimum subset that still covers every branch extract-schemas --fuzz --minimize-corpus lib/My/Module.pm # Generate round-trip tests that run every code example in a module's POD and verify the results pod-example-tester lib/My/Module.pm --output t/pod_examples.t # Generate a Benchmark::cmpthese script from a schema; each transform becomes one timed variant benchmark-generator -i schemas/abs.yml -o benchmarks/abs.pl # Copy dashboard.yml and mutate.yml into a module repository's .github/workflows/ directory deploy-workflows --target /path/to/my-module From Perl: use App::Test::Generator qw(generate); use App::Test::Generator::SchemaExtractor; # Generate to STDOUT App::Test::Generator->generate("t/conf/abs.yml"); # Generate directly to a file App::Test::Generator->generate('t/conf/abs.yml', 't/add_fuzz.t'); # Holy grail mode - read a Perl file, generate tests, and run them # This is a long way away yet, but see t/schema_input.t for a proof of concept my $extractor = App::Test::Generator::SchemaExtractor->new( input_file => 'lib/App/Test/Generator/Template.pm', output_dir => '/tmp', ); my $schemas = $extractor->extract_all(); use File::Temp qw(tempfile); foreach my $schema(keys %{$schemas}) { my ($fh, $tempfile) = tempfile(SUFFIX => '.t', UNLINK => 1); close $fh; App::Test::Generator->generate( schema => $schemas->{$schema}, output_file => $tempfile, ); system($^X, '-Ilib', $tempfile); } =head1 OVERVIEW This module takes a formal input/output specification for a routine or method and automatically generates test cases. In effect, it allows you to easily add comprehensive black-box tests in addition to the more common white-box tests that are typically written for CPAN modules and other subroutines. The generated tests combine: =over 4 =item * Random fuzzing based on input types =item * Deterministic edge cases for min/max constraints =item * Static corpus tests defined in Perl or YAML =back This approach strengthens your test suite by probing both expected and unexpected inputs, helping you to catch boundary errors, invalid data handling, and regressions without manually writing every case. =head1 TOOLS The distribution ships the following command-line tools: =over 4 =item * L<benchmark-generator> - generate a self-contained L<Benchmark> C<cmpthese> script from a YAML schema. Each transform in the schema becomes one named variant; representative input values are derived from each parameter's type and range constraints. =item * L<deploy-workflows> - copy C<dashboard.yml> and C<mutate.yml> into the target repository's C<.github/workflows/> directory. Both files are embedded verbatim in the script, so no ATG source tree is needed after installation. Supports C<--target>, C<--force>, and C<--dry-run>. To add a test dashboard to your CPAN module: copy these scripts into your C<.github/workflows> directory, then commit the changes to GitHub and enable the page through C<Settings-Pages-branch = gh_pages>: =over 4 =item * L<https://github.com/nigelhorne/App-Test-Generator/blob/master/.github/workflows/dashboard.yml> =item * L<https://github.com/nigelhorne/App-Test-Generator/blob/master/.github/workflows/mutate.yml> =back =item * L<extract-schemas> - heuristically extract YAML parameter schemas from a C<.pm> file, with optional coverage-guided fuzzing (C<--fuzz>) and corpus minimization (C<--minimize-corpus>). =item * L<fuzz-harness-generator> - generate a C<Test::Most> fuzzing harness from a YAML schema. =item * L<pod-example-tester> - generate a C<Test::Most> round-trip test file from a module's POD code examples. Annotated examples (C<# returns value> / C<< # => value >>) get C<is()> assertions; unannotated verbatim blocks are wrapped in C<eval{}> and checked for no exception. =item * L<test-generator-mutate> - run mutation testing against a module's test suite. =item * L<test-generator-index> - generate the HTML test-quality dashboard, combining Devel::Cover statement/branch data, LCSAJ path coverage, mutation results, and CPAN Testers failure analysis. For each CPAN Testers FAIL report, also writes a self-contained shell script (C<cover_html/reproduce/reproduce-GUID.sh>) that pins every installed module at its exact failing version, enabling local reproduction of the failure environment. =back =head1 DESCRIPTION This module implements the logic behind L<fuzz-harness-generator>. It parses configuration files (fuzz and/or corpus YAML), and produces a ready-to-run F<.t> test script to run through C<prove>. It reads configuration files in any format, and optional YAML corpus files. All of the examples in this documentation are in C<YAML> format, other formats may not work as they aren't so heavily tested. It then generates a L<Test::Most>-based fuzzing harness combining: =over 4 =item * Randomized fuzzing of inputs (with edge cases) =item * Optional static corpus tests from Perl C<%cases> or YAML file (C<yaml_cases> key) =item * Functional or OO mode (via C<$new>) =item * Reproducible runs via C<$seed> and configurable iterations via C<$iterations> =back =head1 MUTATION-GUIDED TEST GENERATION C<App::Test::Generator> includes a pipeline that automatically closes the feedback loop between mutation testing, schema extraction, and fuzz testing. The goal is that surviving mutants drive the creation of new tests that kill them on the next run, without manual intervention. =head2 The Pipeline mutation survivor \| v SchemaExtractor extracts the schema for the enclosing sub \| v Schema augmented with boundary values from the mutant \| v Augmented schema written to t/conf/ \| v t/fuzz.t picks up the new schema and runs fuzz tests \| v Mutation killed on next run =head2 How to Use It The pipeline is driven by three flags passed to C<bin/test-generator-index>, which is invoked automatically by C<bin/generate-test-dashboard> on each CI push. =head3 Step 1: Generate TODO stubs for all survivors bin/test-generator-index --generate_mutant_tests=t Produces C<t/mutant_YYYYMMDD_HHMMSS.t> containing: =over 4 =item * TODO stubs for HIGH and MEDIUM difficulty survivors, with boundary value suggestions, environment variable hints, and the enclosing subroutine name for navigation context. =item * Comment-only hints for LOW difficulty survivors. =back Multiple mutations on the same source line are deduplicated into one stub. One good test kills all variants on that line. =head3 Step 2: Generate runnable schemas for NUM_BOUNDARY survivors bin/test-generator-index \ --generate_mutant_tests=t \ --generate_test=mutant For each NUM_BOUNDARY survivor, calls L<App::Test::Generator::SchemaExtractor> to extract the schema for the enclosing subroutine. If the confidence level is sufficient, the schema is augmented with the boundary value from the mutant (plus one value either side) and written to C<t/conf/> as a runnable YAML file. L<t/fuzz.t> picks it up automatically on the next test run. Falls back to a TODO stub if: =over 4 =item * SchemaExtractor cannot parse the file =item * The enclosing sub cannot be determined =item * The extracted schema confidence is C<very_low> or C<none> =back =head3 Step 3: Augment existing schemas with survivor boundary values bin/test-generator-index \ --generate_mutant_tests=t \ --generate_test=mutant \ --generate_fuzz Scans C<t/conf/> for existing YAML schema files (hand-written or previously generated) and writes augmented copies with boundary values from surviving NUM_BOUNDARY mutants merged in. The original schema is never modified. Augmented copies are written as C<t/conf/mutant_fuzz_YYYYMMDD_HHMMSS_FUNCTION.yml> and picked up automatically by C<t/fuzz.t>. Schemas whose filename already starts with C<mutant_fuzz_> are skipped to prevent cascading augmentation. Schemas with no matching survivors are skipped, with a note if C<--verbose> is active. =head3 Putting It All Together The recommended invocation in C<bin/generate-test-dashboard> Step 7 runs all three stages together: bin/test-generator-index \ --generate_mutant_tests=t \ --generate_test=mutant \ --generate_fuzz The GitHub Actions workflow in C<.github/workflows/dashboard.yml> then commits any new C<t/mutant_.t> and C<t/conf/mutant_.yml> files to the repository so they accumulate over time as the test suite improves. =head2 Confidence Levels L<App::Test::Generator::SchemaExtractor> assigns a confidence level to each extracted schema: =over 4 =item * C<high> / C<medium> / C<low> - Schema is used for test generation =item * C<very_low> / C<none> - Falls back to TODO stub =back Confidence is based on how much type and constraint information could be inferred from the source code and its POD documentation. Methods with explicit parameter validation (L<Params::Validate::Strict>, L<Params::Get>) or comprehensive POD will produce higher-confidence schemas. =head2 Files Produced =over 4 =item * C<t/mutant_YYYYMMDD_HHMMSS.t> TODO stub file for all survivors. Committed to the repository by the GitHub Actions workflow. =item * C<t/conf/mutant_MODNAME_FUNCTION_YYYYMMDD_HHMMSS.yml> Runnable YAML schema for a NUM_BOUNDARY survivor where SchemaExtractor confidence was sufficient. Picked up by C<t/fuzz.t>. =item * C<t/conf/mutant_fuzz_YYYYMMDD_HHMMSS_FUNCTION.yml> Augmented copy of an existing schema with survivor boundary values merged in. Picked up by C<t/fuzz.t>. =back =head2 See Also =over 4 =item * L<App::Test::Generator::SchemaExtractor> - Schema extraction from Perl source code =item * L<bin/test-generator-index> - Dashboard generator and pipeline driver =item * L<bin/generate-test-dashboard> - Full pipeline runner =back =encoding utf8 =head1 CONFIGURATION The configuration file, for each set of tests to be produced, is a file containing a schema that can be read by L<Config::Abstraction>. =head2 SCHEMA The schema is split into several sections. =head3 C<%input> - input params with keys => type/optional specs When using named parameters input: name: type: string optional: false age: type: integer optional: true Supported basic types used by the fuzzer: C<string>, C<integer>, C<float>, C<number>, C<boolean>, C<arrayref>, C<hashref>. See also L<Params::Validate::Strict>. You can add more custom types using properties. For routines with one unnamed parameter input: type: string For routines with more than one named parameter, use the C<position> keyword. module: Math::Simple::MinMax fuction: max input: left: type: number position: 0 right: type: number position: 1 output: type: number The keyword C<undef> is used to indicate that the C<function> takes no arguments. =head3 C<%output> - output param types for L<Return::Set> checking output: type: string If the output hash contains the key _STATUS, and if that key is set to DIES, the routine should die with the given arguments; otherwise, it should live. If it's set to WARNS, the routine should warn with the given arguments. The output can be set to the string 'undef' if the routine should return the undefined value: --- module: Scalar::Util function: blessed input: type: string output: undef The keyword C<undef> is used to indicate that the C<function> returns nothing. For methods that return a list (rather than a reference), use C<type: array>. The generated test captures the result in list context and validates it as an arrayref, which requires L<Test::Returns> 0.03 or later: output: type: array =head3 C<%config> - optional hash of configuration. The current supported variables are =over 4 =item * C<close_stdin> Tests should not attempt to read from STDIN (default: 1). This is ignored on Windows, when never closes STDIN. =item * C<test_nuls>, inject NUL bytes into strings (default: 1) With this test enabled, the function is expected to die when a NUL byte is passed in. =item * C<test_undef>, test with undefined value (default: 1) =item * C<test_empty>, test with empty strings (default: 1) =item * C<test_non_ascii>, test with strings that contain non ascii characters (default: 1) =item * C<timeout>, ensure tests don't hang (default: 10) Setting this to 0 disables timeout testing. =item * C<dedup>, fuzzing can create duplicate tests, go some way to remove duplicates (default: 1) =item * C<properties>, enable L<Test::LectroTest> Property tests (default: 0) item C<test_security>, send some security string based tests (default: 0) =back All values default to C<true>. =head3 C<%accessor> - this is an accessor routine accessor: property: ua type: getset Has two mandatory elements: =over 4 =item * C<property> The name of the property in the object that the routine controls. =item * C<type> One of C<getter>, C<setter>, C<getset>. =back =head3 C<%transforms> - list of transformations from input sets to output sets Transforms allow you to define how input data should be transformed into output data. This is useful for testing functions that convert between formats, normalize data, or apply business logic transformations on a set of data to different set of data. It takes a list of subsets of the input and output definitions, and verifies that data from each input subset is correctly transformed into data from the matching output subset. =head4 Transform Validation Rules For each transform: =over 4 =item 1. Generate test cases using the transform's input schema =item 2. Call the function with those inputs =item 3. Validate the output matches the transform's output schema =item 4. If output has a specific 'value', check exact match =item 5. If output has constraints (min/max), validate within bounds =back =head4 Example 1 --- module: builtin function: abs config: test_undef: no test_empty: no test_nuls: no test_non_ascii: no input: number: type: number position: 0 output: type: number min: 0 transforms: positive: input: number: type: number position: 0 min: 0 output: type: number min: 0 negative: input: number: type: number position: 0 max: 0 output: type: number min: 0 error: input: undef output: _STATUS: DIES If the output hash contains the key _STATUS, and if that key is set to DIES, the routine should die with the given arguments; otherwise, it should live. If it's set to WARNS, the routine should warn with the given arguments. The keyword C<undef> is used to indicate that the C<function> returns nothing. =head4 Example 2 --- module: Math::Utils function: normalize_number input: value: type: number position: 0 output: type: number transforms: positive_stays_positive: input: value: type: number min: 0 max: 1000 output: type: number min: 0 max: 1 negative_becomes_zero: input: value: type: number max: 0 output: type: number value: 0 preserves_zero: input: value: type: number value: 0 output: type: number value: 0 =head3 C<$module> The name of the module (optional). Using the reserved word C<builtin> means you're testing a Perl builtin function. If omitted, the generator will guess from the config filename: C<My-Widget.conf> -> C<My::Widget>. =head3 C<$function> The function/method to test. This defaults to C<run>. =head3 C<%new> An optional hashref of args to pass to the module's constructor. new: api_key: ABC123 verbose: true To ensure C<new()> is called with no arguments, you still need to define new, thus: module: MyModule function: my_function new: =head3 C<%cases> An optional Perl static corpus, when the output is a simple string (expected => [ args... ]). Maps the expected output string to the input and _STATUS cases: ok: input: ping _STATUS: OK error: input: "" _STATUS: DIES =head3 C<$yaml_cases> - optional path to a YAML file with the same shape as C<%cases>. =head3 C<$seed> An optional integer. When provided, the generated C<t/fuzz.t> will call C<srand($seed)> so fuzz runs are reproducible. =head3 C<$iterations> An optional integer controlling how many fuzz iterations to perform (default 30). =head3 C<%edge_cases> An optional hash mapping of extra values to inject. # Two named parameters edge_cases: name: [ '', 'a' x 1024, \"\x{263A}" ] age: [ -1, 0, 99999999 ] # Takes a string input edge_cases: [ 'foo', 'bar' ] Values can be strings or numbers; strings will be properly quoted. Note that this only works with routines that take named parameters. =head3 C<%type_edge_cases> An optional hash mapping types to arrayrefs of extra values to try for any field of that type: type_edge_cases: string: [ '', ' ', "\t", "\n", "\0", 'long' x 1024, chr(0x1F600) ] number: [ 0, 1.0, -1.0, 1e308, -1e308, 1e-308, -1e-308, 'NaN', 'Infinity' ] integer: [ 0, 1, -1, 231-1, -(231), 263-1, -(263) ] =head3 C<%edge_case_array> Specify edge case values for routines that accept a single unnamed parameter. This is specifically designed for simple functions that take one argument without a parameter name. These edge cases supplement the normal random string generation, ensuring specific problematic values are always tested. During fuzzing iterations, there's a 40% probability that a test case will use a value from edge_case_array instead of randomly generated data. --- module: Text::Processor function: sanitize input: type: string min: 1 max: 1000 edge_case_array: - "<script>alert('xss')</script>" - "'; DROP TABLE users; --" - "\0null\0byte" - "emojiðŸ˜Štest" - "" - " " seed: 42 iterations: 30 =head3 Semantic Data Generators For property-based testing with L<Test::LectroTest>, you can use semantic generators to create realistic test data. C<unix_timestamp> is currently fully supported, other fuzz testing support for C<semantic> entries is being developed. input: email: type: string semantic: email user_id: type: string semantic: uuid phone: type: string semantic: phone_us =head4 Available Semantic Types =over 4 =item * C<email> - Valid email addresses (user@domain.tld) =item * C<url> - HTTP/HTTPS URLs =item * C<uuid> - UUIDv4 identifiers =item * C<phone_us> - US phone numbers (XXX-XXX-XXXX) =item * C<phone_e164> - International E.164 format (+XXXXXXXXXXXX) =item * C<ipv4> - IPv4 addresses (0.0.0.0 - 255.255.255.255) =item * C<ipv6> - IPv6 addresses =item * C<username> - Alphanumeric usernames with _ and - =item * C<slug> - URL slugs (lowercase-with-hyphens) =item * C<hex_color> - Hex color codes (#RRGGBB) =item * C<iso_date> - ISO 8601 dates (YYYY-MM-DD) =item * C<iso_datetime> - ISO 8601 datetimes (YYYY-MM-DDTHH:MM:SSZ) =item * C<semver> - Semantic version strings (major.minor.patch) =item * C<jwt> - JWT-like tokens (base64url format) =item * C<json> - Simple JSON objects =item * C<base64> - Base64-encoded strings =item * C<md5> - MD5 hashes (32 hex chars) =item * C<sha256> - SHA-256 hashes (64 hex chars) =item * C<unix_timestamp> =back =head2 EDGE CASE GENERATION In addition to purely random fuzz cases, the harness generates deterministic edge cases for parameters that declare C<min>, C<max> or C<len> in their schema definitions. For each constraint, three edge cases are added: =over 4 =item * Just inside the allowable range This case should succeed, since it lies strictly within the bounds. =item * Exactly on the boundary This case should succeed, since it meets the constraint exactly. =item * Just outside the boundary This case is annotated with C<_STATUS = 'DIES'> in the corpus and should cause the harness to fail validation or croak. =back Supported constraint types: =over 4 =item * C<number>, C<integer>, C<float> Uses numeric values one below, equal to, and one above the boundary. =item * C<string> Uses strings of lengths one below, equal to, and one above the boundary. =item * C<arrayref> Uses references to arrays of with the number of elements one below, equal to, and one above the boundary. =item * C<hashref> Uses hashes with key counts one below, equal to, and one above the boundary (C<min> = minimum number of keys, C<max> = maximum number of keys). =item * C<memberof> - arrayref of allowed values for a parameter This example is for a routine called C<input()> that takes two arguments: C<status> and C<level>. C<status> is a string that must have the value C<ok>, C<error> or C<pending>. The C<level> argument is an integer that must be one of C<1>, C<5> or C<111>. --- input: status: type: string memberof: - ok - error - pending level: type: integer memberof: - 1 - 5 - 111 The generator will automatically create test cases for each allowed value (inside the member list), and at least one value outside the list (which should die or C<croak>, C<_STATUS = 'DIES'>). This works for strings, integers, and numbers. =item * C<enum> - synonym of C<memberof> =item * C<boolean> - automatic boundary tests for boolean fields input: flag: type: boolean The generator will automatically create test cases for 0 and 1; true and false; off and on, and values that should trigger C<_STATUS = 'DIES'>. =back These edge cases are inserted automatically, in addition to the random fuzzing inputs, so each run will reliably probe boundary conditions without relying solely on randomness. =head1 EXAMPLES See the files in C<t/conf> for examples. =head2 Adding Scheduled fuzz Testing with GitHub Actions to Your Code To automatically create and run tests on a regular basis on GitHub Actions, you need to create a configuration file for each method and subroutine that you're testing, and a GitHub Actions configuration file. This example takes you through testing the online_render method of L<HTML::Genealogy::Map>. =head3 t/conf/online_render.yml --- module: HTML::Genealogy::Map function: onload_render input: gedcom: type: object can: individuals geocoder: type: object can: geocode debug: type: boolean optional: true google_key: type: string optional: true min: 39 max: 39 matches: "^AIza[0-9A-Za-z_-]{35}$" config: test_undef: 0 =head3 .github/actions/fuzz.t --- name: Fuzz Testing permissions: contents: read on: push: branches: [main, master] pull_request: branches: [main, master] schedule: - cron: '29 5 14 * ' jobs: generate-fuzz-tests: strategy: fail-fast: false matrix: os: - macos-latest - ubuntu-latest - windows-latest perl: ['5.42', '5.40', '5.38', '5.36', '5.34', '5.32', '5.30', '5.28', '5.22'] runs-on: ${{ matrix.os }} name: Fuzz testing with perl ${{ matrix.perl }} on ${{ matrix.os }} steps: - uses: actions/checkout@df4cb1c069e1874edd31b4311f1884172cec0e10 # v6 - name: Set up Perl uses: shogo82148/actions-setup-perl@a198315ec4e9244f206879ea7b63078003aec8a6 # v1.41.1 with: perl-version: ${{ matrix.perl }} - name: Install App::Test::Generator this module's dependencies run: \| cpanm App::Test::Generator cpanm --installdeps . - name: Make Module run: \| perl Makefile.PL make env: AUTOMATED_TESTING: 1 NONINTERACTIVE_TESTING: 1 - name: Generate fuzz tests run: \| mkdir t/fuzz find t/conf -name '.yml' \| while read config; do test_name=$(basename "$config" .conf) fuzz-harness-generator "$config" > "t/fuzz/${test_name}_fuzz.t" done - name: Run generated fuzz tests run: \| prove -lr t/fuzz/ env: AUTOMATED_TESTING: 1 NONINTERACTIVE_TESTING: 1 =head2 Fuzz Testing your CPAN Module Running fuzz tests when you run C<make test> in your CPAN module. Create a directory <t/conf> which contains the schemas. Then create this file as <t/fuzz.t>: #!/usr/bin/env perl use strict; use warnings; use FindBin qw($Bin); use IPC::Run3; use IPC::System::Simple qw(system); use Test::Needs 'App::Test::Generator'; use Test::Most; my $dirname = "$Bin/conf"; if((-d $dirname) && opendir(my $dh, $dirname)) { while (my $filename = readdir($dh)) { # Skip '.' and '..' entries and vi temporary files next if ($filename eq '.' \|\| $filename eq '..') \|\| ($filename =~ /\.swp$/); my $filepath = "$dirname/$filename"; if(-f $filepath) { # Check if it's a regular file my ($stdout, $stderr); run3 ['fuzz-harness-generator', '-r', $filepath], undef, \$stdout, \$stderr; ok($? == 0, 'Generated test script exits successfully'); if($? == 0) { ok($stdout =~ /^Result: PASS/ms); if($stdout =~ /Files=1, Tests=(\d+)/ms) { diag("$1 tests run"); } } else { diag("$filepath: STDOUT:\n$stdout"); diag($stderr) if(length($stderr)); diag("$filepath Failed"); last; } diag($stderr) if(length($stderr)); } } closedir($dh); } done_testing(); =head2 Property-Based Testing with Transforms The generator can create property-based tests using L<Test::LectroTest> when the C<properties> configuration option is enabled. This provides more comprehensive testing by automatically generating thousands of test cases and verifying that mathematical properties hold across all inputs. =head3 Basic Property-Based Transform Example Here's a complete example testing the C<abs> builtin function: B<t/conf/abs.yml>: --- module: builtin function: abs config: test_undef: no test_empty: no test_nuls: no properties: enable: true trials: 1000 input: number: type: number position: 0 output: type: number min: 0 transforms: positive: input: number: type: number min: 0 output: type: number min: 0 negative: input: number: type: number max: 0 output: type: number min: 0 This configuration: =over 4 =item * Enables property-based testing with 1000 trials per property =item * Defines two transforms: one for positive numbers, one for negative =item * Automatically generates properties that verify C<abs()> always returns non-negative numbers =back Generate the test: fuzz-harness-generator t/conf/abs.yml > t/abs_property.t The generated test will include: =over 4 =item * Traditional edge-case tests for boundary conditions =item * Random fuzzing with 30 iterations (or as configured) =item * Property-based tests that verify the transforms with 1000 trials each =back =head3 What Properties Are Tested? The generator automatically detects and tests these properties based on your transform specifications: =over 4 =item * B<Range constraints> - If output has C<min> or C<max>, verifies results stay within bounds =item * B<Type preservation> - Ensures numeric inputs produce numeric outputs =item * B<Definedness> - Verifies the function doesn't return C<undef> unexpectedly =item * B<Specific values> - If output specifies a C<value>, checks exact equality =back For the C<abs> example above, the generated properties verify: # For the "positive" transform: - Given a positive number, abs() returns >= 0 - The result is a valid number - The result is defined # For the "negative" transform: - Given a negative number, abs() returns >= 0 - The result is a valid number - The result is defined =head3 Advanced Example: String Normalization Here's a more complex example testing a string normalization function: B<t/conf/normalize.yml>: --- module: Text::Processor function: normalize_whitespace config: properties: enable: true trials: 500 input: text: type: string min: 0 max: 1000 position: 0 output: type: string min: 0 max: 1000 transforms: empty_preserved: input: text: type: string value: "" output: type: string value: "" single_space: input: text: type: string min: 1 matches: '^\S+(\s+\S+)$' output: type: string matches: '^\S+( \S+)$' length_bounded: input: text: type: string min: 1 max: 100 output: type: string min: 1 max: 100 This tests that the normalization function: =over 4 =item * Preserves empty strings (C<empty_preserved> transform) =item * Collapses multiple spaces into single spaces (C<single_space> transform) =item * Maintains length constraints (C<length_bounded> transform) =back =head3 Interpreting Property Test Results When property-based tests run, you'll see output like: ok 123 - negative property holds (1000 trials) ok 124 - positive property holds (1000 trials) If a property fails, Test::LectroTest will attempt to find the minimal failing case and display it: not ok 123 - positive property holds (47 trials) # Property failed # Reason: counterexample found This helps you quickly identify edge cases that your function doesn't handle correctly. =head3 Configuration Options for Property-Based Testing In the C<config> section: config: properties: enable: true # Enable property-based testing (default: false) trials: 1000 # Number of test cases per property (default: 1000) You can also disable traditional fuzzing and only use property-based tests: config: properties: enable: true trials: 5000 iterations: 0 # Disable random fuzzing, use only property tests =head3 When to Use Property-Based Testing Property-based testing with transforms is particularly useful for: =over 4 =item * Mathematical functions (C<abs>, C<sqrt>, C<min>, C<max>, etc.) =item * Data transformations (encoding, normalization, sanitization) =item * Parsers and formatters =item * Functions with clear input-output relationships =item * Code that should satisfy mathematical properties (commutativity, associativity, idempotence) =back =head3 Requirements Property-based testing requires both L<Test::LectroTest> and L<Test::LectroTest::Compat> to be installed: cpanm Test::LectroTest Test::LectroTest::Compat L<Test::LectroTest::Compat> provides the C<use_ok> bridge between L<Test::LectroTest> and L<Test::Most>; it is used in every generated property-based test file. Both are declared in the distribution's C<TEST_REQUIRES> so they are installed automatically during C<make test>. If not installed, the generated tests will automatically skip the property-based portion with a message. =head3 Testing Email Validation --- module: Email::Valid function: rfc822 config: properties: enable: true trials: 200 close_stdin: true test_undef: no test_empty: no test_nuls: no input: email: type: string semantic: email position: 0 output: type: boolean transforms: valid_emails: input: email: type: string semantic: email output: type: boolean This generates 200 realistic email addresses for testing, rather than random strings. =head3 Combining Semantic with Regex You can combine semantic generators with regex validation: input: corporate_email: type: string semantic: email matches: '@company\.com$' The semantic generator creates realistic emails, and the regex ensures they match your domain. =head3 Custom Properties for Transforms You can define additional properties that should hold for your transforms beyond the automatically detected ones. =head4 Using Built-in Properties transforms: positive: input: number: type: number min: 0 output: type: number min: 0 properties: - idempotent # f(f(x)) == f(x) - non_negative # result >= 0 - positive # result > 0 Available built-in properties: =over 4 =item * C<idempotent> - Function is idempotent: f(f(x)) == f(x) =item * C<non_negative> - Result is always >= 0 =item * C<positive> - Result is always > 0 =item * C<non_empty> - String result is never empty =item * C<length_preserved> - Output length equals input length =item * C<uppercase> - Result is all uppercase =item * C<lowercase> - Result is all lowercase =item * C<trimmed> - No leading/trailing whitespace =item * C<sorted_ascending> - Array is sorted ascending =item * C<sorted_descending> - Array is sorted descending =item * C<unique_elements> - Array has no duplicates =item * C<preserves_keys> - Hash has same keys as input =back =head4 Custom Property Code Custom properties allows the definition additional invariants and relationships that should hold for their transforms, beyond what's auto-detected. For example: =over 4 =item * Idempotence: f(f(x)) == f(x) =item * Commutativity: f(x, y) == f(y, x) =item * Associativity: f(f(x, y), z) == f(x, f(y, z)) =item * Inverse relationships: decode(encode(x)) == x =item * Domain-specific invariants: Custom business logic =back Define your own properties with custom Perl code: transforms: normalize: input: text: type: string output: type: string properties: - name: single_spaces description: "No multiple consecutive spaces" code: $result !~ / / - name: no_leading_space description: "No space at start" code: $result !~ /^\s/ - name: reversible description: "Can be reversed back" code: length($result) == length($text) The code has access to: =over 4 =item * C<$result> - The function's return value =item * Input variables - All input parameters (e.g., C<$text>, C<$number>) =item * The function itself - Can call it again for idempotence checks =back =head4 Combining Auto-detected and Custom Properties The generator automatically detects properties from your output spec, and adds your custom properties: transforms: sanitize: input: html: type: string output: type: string min: 0 # Auto-detects: defined, min_length >= 0 max: 10000 properties: # Additional custom checks: - name: no_scripts code: $result !~ /<script/i - name: no_iframes code: $result !~ /<iframe/i =head2 GENERATED OUTPUT The generated test: =over 4 =item * Seeds RND (if configured) for reproducible fuzz runs =item * Uses edge cases (per-field and per-type) with configurable probability =item * Runs C<$iterations> fuzz cases plus appended edge-case runs =item * Validates inputs with Params::Get / Params::Validate::Strict =item * Validates outputs with L<Return::Set> =item * Runs static C<is(... )> corpus tests from Perl and/or YAML corpus =item * Runs L<Test::LectroTest> tests =back =cut
1594
1595 - 1624						=head1 METHODS =head2 generate Takes a schema file and produces a test file (or STDOUT). # Modern named API App::Test::Generator->generate( schema_file => 'schemas/foo.yml', output_file => 'test/foo.t', ); # Legacy positional API App::Test::Generator->generate($schema_file, $test_file); =head3 API Specification =head4 Input { schema_file => { type => 'string', optional => 0 }, input_file => { type => 'string', optional => 1 }, output_file => { type => 'string', optional => 1, max => 255 }, } =head4 Output { type => 'string' } =cut
1625
1626						sub generate
1627						{
1628	107	50		107	3314616	croak 'Usage: generate(schema_file [, outfile])' if(scalar(@_) == 0);
1629
1630						# Accept both class-method call (App::Test::Generator->generate(...))
1631						# and plain-function call with a hashref (generate({...})).
1632						# In the method form the first arg is the class name (a plain string);
1633						# in the function form with a hashref the first arg IS the hashref.
1634	107	50			239	my $class = (ref($_[0]) ne 'HASH') ? shift : undef;
1635	107				244	my ($schema_file, $test_file, $schema);
1636						# Globals loaded from the user's conf (all optional except function maybe)
1637	107				0	my ($module, $function, $new, $yaml_cases);
1638	107				0	my ($seed, $iterations);
1639
1640	107	100	100		369	if((ref($_[0]) eq 'HASH') \|\| defined($_[2])) {
1641						# Modern API
1642	14				79	my $params = Params::Validate::Strict::validate_strict({
1643						args => Params::Get::get_params(undef, \@_),
1644						schema => {
1645						input_file => { type => 'string', optional => 1 },
1646						schema_file => { type => 'string', optional => 1 },
1647						output_file => { type => 'string', optional => 1 },
1648						schema => { type => 'hashref', optional => 1 },
1649						quiet => { type => 'boolean', optional => 1 }, # Not yet used
1650						}
1651						});
1652	14	100 100 50			2676	if($params->{'schema_file'}) {
1653	5				7	$schema_file = $params->{'schema_file'};
1654						} elsif($params->{'input_file'}) {
1655	1				2	$schema_file = $params->{'input_file'};
1656						} elsif($params->{'schema'}) {
1657	8				13	$schema = $params->{'schema'};
1658						} else {
1659	0				0	croak(__PACKAGE__, ': Usage: generate(input_file\|schema [, output_file]');
1660						}
1661	14	100			28	if(defined($schema_file)) {
1662	6				12	$schema = _load_schema($schema_file);
1663						}
1664	14				79	$test_file = $params->{'output_file'};
1665						} else {
1666						# Legacy API
1667	93				124	($schema_file, $test_file) = @_;
1668	93	100			152	if(defined($schema_file)) {
1669	88				188	$schema = _load_schema($schema_file);
1670						} else {
1671	5				30	croak 'Usage: generate(schema_file [, outfile])';
1672						}
1673						}
1674
1675						# Parse the schema file and load into our structures
1676	99 99				894 211	my %input = %{_load_schema_section($schema, 'input', $schema_file)};
1677	98 98				130 101	my %output = %{_load_schema_section($schema, 'output', $schema_file)};
1678	97 97				109 123	my %transforms = %{_load_schema_section($schema, 'transforms', $schema_file)};
1679	96 96				99 95	my %accessor = %{_load_schema_section($schema, 'accessor', $schema_file)};
1680
1681	96 2	100			183 4	my %cases = %{$schema->{cases}} if(exists($schema->{cases}));
1682	96 0	50			138 0	my %edge_cases = %{$schema->{edge_cases}} if(exists($schema->{edge_cases}));
1683	96 1	100			176 2	my %type_edge_cases = %{$schema->{type_edge_cases}} if(exists($schema->{type_edge_cases}));
1684
1685	96	100	67		314	$module = $schema->{module} if(exists($schema->{module}) && length($schema->{module}));
1686	96	100			175	$function = $schema->{function} if(exists($schema->{function}));
1687	96	100			164	if(exists($schema->{new})) {
1688	19	100			33	$new = defined($schema->{'new'}) ? $schema->{new} : '_UNDEF';
1689						}
1690	96	100			142	$yaml_cases = $schema->{yaml_cases} if(exists($schema->{yaml_cases}));
1691	96	100			137	$seed = $schema->{seed} if(exists($schema->{seed}));
1692	96	100			137	$iterations = $schema->{iterations} if(exists($schema->{iterations}));
1693
1694	96 3	100			230 6	my @edge_case_array = @{$schema->{edge_case_array}} if(exists($schema->{edge_case_array}));
1695	96				201	_validate_config($schema);
1696
1697	93 10	100			178 38	my %config = %{$schema->{config}} if(exists($schema->{config}));
1698
1699	93				203	_normalize_config(\%config);
1700
1701						# Guess module name from config file if not set
1702	93	100 100			429	if(!$module) {
1703	5	100			9	if($schema_file) {
1704	4				70	($module = basename($schema_file)) =~ s/\.(conf\|pl\|pm\|yml\|yaml)$//;
1705	4				5	$module =~ s/-/::/g;
1706						# Guard against Perl builtin function names being mistaken
1707						# for module names â€” builtins have no module to load
1708	4	100			6	if(_is_perl_builtin($module)) {
1709	1				1	undef $module;
1710						}
1711						}
1712						} elsif($module eq $MODULE_BUILTIN) {
1713	54				158	undef $module;
1714						}
1715
1716	93	50	50		286	if($module && length($module) && ($module ne 'builtin')) {
1717	37				64	_validate_module($module, $schema_file);
1718						}
1719
1720						# $module/$function are spliced unescaped into generated test
1721						# source below (use_ok, new_ok, ->$function, $module::$function)
1722						# â€” reject anything that isn't identifier-shaped before that happens.
1723	93	100	67		235	_assert_identifier($module, 'module', package => 1) if defined($module) && length($module);
1724
1725						# sensible defaults
1726	92		50		124	$function \|\|= 'run';
1727						# package => 1: fully-qualified sub names (e.g. DB::DB, a debugger
1728						# hook installed into the DB:: package regardless of its source
1729						# package) are legitimate function names, not just bare identifiers
1730	92				165	_assert_identifier($function, 'function', package => 1);
1731	90		67		250	$iterations \|\|= $DEFAULT_ITERATIONS; # default fuzz runs if not specified
1732	90	50	67		371	$seed = undef if defined $seed && $seed eq ''; # treat empty as undef
1733
1734						# --- YAML corpus support (yaml_cases is filename string) ---
1735	90				67	my %yaml_corpus_data;
1736	90	100			106	if (defined $yaml_cases) {
1737	5	100			64	croak("$yaml_cases: $!") if(!-f $yaml_cases);
1738
1739	4				12	my $yaml_data = LoadFile(Encode::decode('utf8', $yaml_cases));
1740	4	50	33		273	if ($yaml_data && ref($yaml_data) eq 'HASH') {
1741						# Validate that the corpus inputs are arrayrefs
1742						# e.g: "FooBar": ["foo_bar"]
1743						# Skip only invalid entries:
1744	4 4				20 9	for my $expected (keys %{$yaml_data}) {
1745	6				6	my $outputs = $yaml_data->{$expected};
1746	6	100	67		16	unless($outputs && (ref $outputs eq 'ARRAY')) {
1747	2				12	carp("$yaml_cases: $expected does not point to an array ref, ignoring");
1748	2				197	next;
1749						}
1750	4				7	$yaml_corpus_data{$expected} = $outputs;
1751						}
1752						}
1753						}
1754
1755						# Merge Perl %cases and YAML corpus safely
1756						# my %all_cases = (%cases, %yaml_corpus_data);
1757	89				133	my %all_cases = (%yaml_corpus_data, %cases);
1758	89				133	for my $k (keys %yaml_corpus_data) {
1759	4	50	50		10	if (exists $cases{$k} && ref($cases{$k}) eq 'ARRAY' && ref($yaml_corpus_data{$k}) eq 'ARRAY') {
1760	1 1 1				1 2 2	$all_cases{$k} = [ @{$yaml_corpus_data{$k}}, @{$cases{$k}} ];
1761						}
1762						}
1763
1764	89	100			171	if(my $hints = delete $schema->{_yamltest_hints}) {
1765	8	50			19	if(my $boundaries = $hints->{boundary_values}) {
1766	8 8				6 20	push @edge_case_array, @{$boundaries};
1767						}
1768	8	50			28	if(my $invalid = $hints->{invalid}) {
1769	0				0	carp('TODO: handle yamltest_hints->invalid');
1770						}
1771						}
1772
1773						# If the schema says the type is numeric, normalize
1774	89	100	67		177	if ($schema->{type} && $schema->{type} =~ /^(integer\|number\|float)$/) {
1775	1				2	for (@edge_case_array) {
1776	2	50			5	next unless defined $_;
1777	2	100			8	$_ += 0 if Scalar::Util::looks_like_number($_);
1778						}
1779						}
1780
1781						# Load relationships from the schema if present and well-formed.
1782						# SchemaExtractor may set this to undef or an empty arrayref when
1783						# no relationships were detected, so guard both existence and type.
1784	89				77	my @relationships;
1785	89	50	33		185	if(exists($schema->{relationships}) && ref($schema->{relationships}) eq 'ARRAY') {
1786	0 0				0 0	@relationships = @{$schema->{relationships}};
1787						}
1788
1789						# Serialise the relationships array from the schema into Perl source
1790						# code for embedding in the generated test file. Each relationship
1791						# type is rendered as a hashref in the @relationships array.
1792
1793	89				120	my $relationships_code = '';
1794
1795						# Walk each relationship in the order SchemaExtractor produced them
1796	89				135	for my $rel (@relationships) {
1797	0		0		0	my $type = $rel->{type} // '';
1798
1799						# Mutually exclusive: both params being set should cause the method to die
1800	0	0 0 0 0 0 0			0	if($type eq 'mutually_exclusive') {
1801						$relationships_code .= "{ type => 'mutually_exclusive', params => [" .
1802	0 0 0				0 0 0	join(', ', map { perl_quote($_) } @{$rel->{params}}) .
1803						"] },\n";
1804
1805						# Required group: at least one of the params must be present
1806						} elsif($type eq 'required_group') {
1807						$relationships_code .= "{ type => 'required_group', params => [" .
1808	0 0				0 0	join(', ', map { perl_quote($_) } @{$rel->{params}}) .
1809	0		0		0	"], logic => " . perl_quote($rel->{logic} // 'or') . " },\n";
1810
1811						# Conditional requirement: if one param is set, another becomes mandatory
1812						} elsif($type eq 'conditional_requirement') {
1813						$relationships_code .= "{ type => 'conditional_requirement', if => " .
1814						perl_quote($rel->{'if'}) . ", then_required => " .
1815	0				0	perl_quote($rel->{then_required}) . " },\n";
1816
1817						# Dependency: one param requires another to also be present
1818						} elsif($type eq 'dependency') {
1819						$relationships_code .= "{ type => 'dependency', param => " .
1820						perl_quote($rel->{param}) . ", requires => " .
1821	0				0	perl_quote($rel->{requires}) . " },\n";
1822
1823						# Value constraint: one param being set forces another to a specific value
1824						} elsif($type eq 'value_constraint') {
1825						$relationships_code .= "{ type => 'value_constraint', if => " .
1826						perl_quote($rel->{'if'}) . ", then => " .
1827						perl_quote($rel->{then}) . ", operator => " .
1828						perl_quote($rel->{operator}) . ", value => " .
1829	0				0	perl_quote($rel->{value}) . " },\n";
1830
1831						# Value conditional: one param equalling a specific value requires another param
1832						} elsif($type eq 'value_conditional') {
1833						$relationships_code .= "{ type => 'value_conditional', if => " .
1834						perl_quote($rel->{'if'}) . ", equals => " .
1835						perl_quote($rel->{equals}) . ", then_required => " .
1836	0				0	perl_quote($rel->{then_required}) . " },\n";
1837
1838						# Unknown type â€” warn and skip rather than emitting broken code
1839						} else {
1840	0				0	carp "Unknown relationship type '$type', skipping";
1841						}
1842						}
1843
1844						# Dedup the edge cases
1845	89				70	my %seen;
1846						@edge_case_array = grep {
1847	89 108	100 50			125 234	my $key = defined($_) ? (Scalar::Util::looks_like_number($_) ? "N:$_" : "S:$_") : 'U';
1848	108				213	!$seen{$key}++;
1849						} @edge_case_array;
1850
1851						# Sort the edge cases to keep it consistent across runs
1852						@edge_case_array = sort {
1853	89 148	50			182 106	return -1 if !defined $a;
1854	148	50			123	return 1 if !defined $b;
1855
1856	148				119	my $na = Scalar::Util::looks_like_number($a);
1857	148				109	my $nb = Scalar::Util::looks_like_number($b);
1858
1859	148	100	100		219	return $a <=> $b if $na && $nb;
1860	18	100			24	return -1 if $na;
1861	13	100			16	return 1 if $nb;
1862	11				15	return $a cmp $b;
1863						} @edge_case_array;
1864
1865						# render edge case maps for inclusion in the .t
1866	89				187	my $edge_cases_code = render_arrayref_map(\%edge_cases);
1867	89				105	my $type_edge_cases_code = render_arrayref_map(\%type_edge_cases);
1868
1869	89				101	my $edge_case_array_code = '';
1870	89	100			102	if(scalar(@edge_case_array)) {
1871	22 98				31 95	$edge_case_array_code = join(', ', map { q_wrap($_) } @edge_case_array);
1872						}
1873
1874						# Render configuration - all the values are integers for now, if that changes, wrap the $config{$key} in single quotes
1875	89				101	my $config_code = '';
1876	89				260	foreach my $key (sort keys %config) {
1877						# Skip nested structures like 'properties' - they're used during
1878						# generation but don't need to be in the generated test
1879	712	100			623	if(ref($config{$key}) eq 'HASH') {
1880	89				77	next;
1881						}
1882	623	100	67		737	if((!defined($config{$key})) \|\| !$config{$key}) {
1883						# YAML will strip the word 'false'
1884						# e.g. in 'test_undef: false'
1885	29				28	$config_code .= "'$key' => 0,\n";
1886						} else {
1887	594				476	$config_code .= "'$key' => $config{$key},\n";
1888						}
1889						}
1890
1891						# Render input/output
1892	89				108	my $input_code = '';
1893	89	100	75		284	if(((scalar keys %input) == 1) && exists($input{'type'}) && !ref($input{'type'})) {
1894						# %input = ( type => 'string' );
1895	50				65	foreach my $key (sort keys %input) {
1896	50				99	$input_code .= "'$key' => '$input{$key}',\n";
1897						}
1898						} else {
1899						# %input = ( str => { type => 'string' } );
1900	39				96	$input_code = render_hash(\%input);
1901						}
1902	89	50			144	if(defined(my $re = $output{'matches'})) {
1903	0	0			0	if(ref($re) ne 'Regexp') {
1904						# Use eval to compile safely â€” qr/$re/ would interpolate
1905						# the string first, corrupting patterns containing [ or \
1906	0 0				0 0	my $compiled = eval { qr/$re/ };
1907	0	0			0	if($@) {
1908	0				0	carp("Invalid matches pattern '$re': $@");
1909						} else {
1910	0				0	$output{'matches'} = $compiled;
1911						}
1912						}
1913						}
1914
1915						# Compile nomatch pattern to a Regexp object so it renders
1916						# as qr{} in the generated test rather than a raw string.
1917						# Without this, patterns containing [ or other regex
1918						# metacharacters cause compilation failures in validators
1919	89	50			139	if(defined(my $re = $output{'nomatch'})) {
1920	0	0			0	if(ref($re) ne 'Regexp') {
1921						# Use eval to compile safely â€” qr/$re/ would interpolate
1922						# the string first, corrupting patterns containing [ or \
1923	0 0				0 0	my $compiled = eval { qr/$re/ };
1924	0	0			0	if($@) {
1925	0				0	carp("Invalid nomatch pattern '$re': $@");
1926						} else {
1927	0				0	$output{'nomatch'} = $compiled;
1928						}
1929						}
1930						}
1931
1932	89				151	my $output_code = render_args_hash(\%output);
1933	89	100	100		181	my $new_code = ($new && (ref $new eq 'HASH')) ? render_args_hash($new) : '';
1934
1935	89				90	my $transforms_code;
1936	89	100			107	if(keys %transforms) {
1937	5				6	foreach my $transform(keys %transforms) {
1938	8				18	my $properties = render_fallback($transforms{$transform}->{'properties'});
1939
1940	8	100			19	if($transforms_code) {
1941	3				3	$transforms_code .= "},\n";
1942						}
1943						$transforms_code .= "$transform => {\n" .
1944						"\t'input' => { " .
1945						render_args_hash($transforms{$transform}->{'input'}) .
1946						"\t}, 'output' => { " .
1947	8				14	render_args_hash($transforms{$transform}->{'output'}) .
1948						"\t}, 'properties' => $properties\n" .
1949						"\t,\n";
1950						}
1951	5				5	$transforms_code .= "}\n";
1952						}
1953
1954	89				84	my $transform_properties_code = '';
1955	89				90	my $use_properties = 0;
1956
1957	89	100	67		119	if (keys %transforms && ($config{properties}{enable} // 0)) {
1958	4				4	$use_properties = 1;
1959
1960						# Generate property-based tests for transforms
1961	4				9	my $properties = _generate_transform_properties(
1962						\%transforms,
1963						$function,
1964						$module,
1965						\%input,
1966						\%config,
1967						$new
1968						);
1969
1970						# Convert to code for template
1971	3				4	$transform_properties_code = _render_properties($properties);
1972						}
1973
1974	88	100			114	if(keys %accessor) {
1975						# Sanity test
1976	7				16	my $property = $accessor{property};
1977	7				7	my $type = $accessor{type};
1978
1979	7	50			14	if(!defined($new)) {
1980						# Internal invariant â€” schema has a contradictory accessor+type combination;
1981						# confess gives the full call chain to aid debugging
1982	0				0	confess("invariant violation: $property: accessor $type can only work on an object, incorrectly tagged as $type");
1983						}
1984	7	100			15	if($type eq 'getset') {
1985	4	100			7	if(scalar(keys %input) != 1) {
1986	1				14	confess("invariant violation: $property: getset must take one input argument, incorrectly tagged as getset");
1987						}
1988	3	100			3	if(scalar(keys %output) == 0) {
1989	1				17	confess("invariant violation: $property: getset must give one output, incorrectly tagged as getset");
1990						}
1991						}
1992						}
1993
1994						# Setup / call code (always load module)
1995	86	100			138	my $setup_code = ($module) ? "BEGIN { use_ok('$module') }" : '';
1996	86				70	my $call_code; # Code to call the function being test when used with named arguments
1997						my $position_code; # Code to call the function being test when used with position arguments
1998	86				131	my $has_positions = _has_positions(\%input);
1999	86	100 100	67 100		707	if(defined($new) && defined($module)) {
2000						# keep use_ok regardless (user found earlier issue)
2001	16	100			20	if($new_code eq '') {
2002	15				17	$new_code = "new_ok('$module')";
2003						} else {
2004	1				1	$new_code = "new_ok('$module' => [ { $new_code } ] )";
2005						}
2006	16				17	$setup_code .= "\nmy \$obj = $new_code;";
2007	16	100			38	if($has_positions) {
2008	5				6	$position_code = "\$result = (scalar(\@alist) == 1) ? \$obj->$function(\$alist[0]) : (scalar(\@alist) == 0) ? \$obj->$function() : \$obj->$function(\@alist);";
2009	5	50			9	if(defined($accessor{type})) {
2010	0	0 0			0	if($accessor{type} eq 'getter') {
2011	0				0	$position_code .= "my \$prev_value = \$obj->{$accessor{property}};";
2012						} elsif($accessor{type} eq 'getset') {
2013	0				0	$position_code .= 'if(scalar(@alist) == 1) { ';
2014	0				0	$position_code .= "cmp_ok(\$result, 'eq', \$alist[0], 'getset function returns what was put in'); ok(\$obj->$function() eq \$result, 'test getset accessor');";
2015	0				0	$position_code .= '}';
2016						}
2017	0	0	0		0	if(($accessor{type} eq 'getset') \|\| ($accessor{type} eq 'getter')) {
2018						# Since Perl doesn't support data encapsulation, we can test the getter returns the correct item
2019	0				0	$position_code .= 'if(scalar(@alist) == 1) { ';
2020	0				0	$position_code .= "cmp_ok(\$result, 'eq', \$obj->{$accessor{property}}, 'getset function returns correct item');";
2021	0	0			0	if($accessor{type} eq 'getter') {
2022	0				0	$position_code .= "if(defined(\$prev_value)) { cmp_ok(\$result, 'eq', \$prev_value, 'getter does not change value'); } ";
2023						}
2024	0				0	$position_code .= '}';
2025						}
2026	0	0			0	if($output{'_returns_self'}) {
2027	0				0	croak("$accessor{type} for $accessor{property} cannot return \$self");
2028						}
2029						}
2030						} else {
2031	11				18	$call_code = "\$result = \$obj->$function(\$input);";
2032	11	50 100	100		41	if($output{'_returns_self'}) {
2033	0				0	$call_code .= "ok(defined(\$result)); ok(\$result eq \$obj, '$function returns self')";
2034						} elsif(defined($accessor{type}) && ($accessor{type} eq 'getset')) {
2035	2				2	$call_code .= "ok(\$obj->$function() eq \$result, 'test getset accessor');"
2036						}
2037	11	100			22	if(scalar(keys %input) == 0) {
2038	6	100	67		21	if(defined($accessor{type}) && ($accessor{type} eq 'getter')) {
2039	3				8	$call_code .= "cmp_ok(\$result, 'eq', \$obj->{$accessor{property}}, 'getter function returns correct item') if(defined(\$result));";
2040						}
2041						}
2042						}
2043						} elsif(defined($module) && length($module)) {
2044	17	100			30	if($function eq 'new') {
2045	2	50			5	if($has_positions) {
2046	0				0	$position_code = "\$result = (scalar(\@alist) == 1) ? ${module}\->$function(\$alist[0]) : (scalar(\@alist) == 0) ? ${module}\->$function() : ${module}\->$function(\@alist);";
2047						} else {
2048	2				4	$call_code = "\$result = ${module}\->$function(\$input);";
2049						}
2050						} else {
2051	15	100			13	if($has_positions) {
2052	1				2	$position_code = "\$result = (scalar(\@alist) == 1) ? ${module}::$function(\$alist[0]) : (scalar(\@alist) == 0) ? ${module}::$function() : ${module}::$function(\@alist);";
2053						} else {
2054	14				17	$call_code = "\$result = ${module}::$function(\$input);";
2055						}
2056						}
2057						} else {
2058	53	100			88	if($has_positions) {
2059	7				10	$position_code = "\$result = $function(\@alist);";
2060						} else {
2061	46				72	$call_code = "\$result = $function(\$input);";
2062						}
2063						}
2064
2065						# List-context capture: $result = func() in scalar context returns a count, not the list.
2066						# When the schema says output type is 'array', capture into @_r then take a ref.
2067	86	100	100		216	if(($output{type} // '') eq 'array') {
2068	2	50			2	if(defined($call_code)) {
2069	2				10	$call_code =~ s/\A\$result = ([^;]+);/my \@_r = ($1); \$result = \\\@_r;/;
2070						}
2071	2	50			2	if(defined($position_code)) {
2072	0				0	$position_code =~ s/\A\$result = ([^;]+);/my \@_r = ($1); \$result = \\\@_r;/;
2073						}
2074						}
2075
2076						# Build static corpus code
2077	86				155	my $corpus_code = '';
2078	86	100			114	if (%all_cases) {
2079	3				4	$corpus_code = "\n# --- Static Corpus Tests ---\n" .
2080						"diag('Running " . scalar(keys %all_cases) . " corpus tests');\n";
2081
2082	3				6	for my $expected (sort keys %all_cases) {
2083	6				6	my $inputs = $all_cases{$expected};
2084	6	50			7	next unless($inputs);
2085
2086	6				9	my $expected_str = perl_quote($expected);
2087	6		33		11	my $status = ((ref($inputs) eq 'HASH') && $inputs->{'_STATUS'}) // 'OK';
2088	6	50 50			9	if($expected_str eq "'_STATUS:DIES'") {
2089	0				0	$status = 'DIES';
2090						} elsif($expected_str eq "'_STATUS:WARNS'") {
2091	0				0	$status = 'WARNS';
2092						}
2093
2094	6	50			8	if(ref($inputs) eq 'HASH') {
2095	0				0	$inputs = $inputs->{'input'};
2096						}
2097	6				4	my $input_str;
2098	6	50 0			10	if(ref($inputs) eq 'ARRAY') {
2099	6 9 6				4 5 7	$input_str = join(', ', map { perl_quote($_) } @{$inputs});
2100						} elsif(ref($inputs) eq 'HASH') {
2101	0				0	$input_str = render_fallback($inputs);
2102
2103						# YAML can't express Perl's undef, so a corpus value of
2104						# the sentinel string 'undef' means "this param is
2105						# undef" -- convert the quoted sentinel back to the
2106						# bareword so the generated test passes real undef
2107	0				0	$input_str =~ s/=> 'undef'/=> undef/gms;
2108						} else {
2109	0				0	$input_str = $inputs;
2110						}
2111	6	50	33		8	if(($input_str eq 'undef') && (!$config{'test_undef'})) {
2112	0				0	carp('corpus case set to undef, yet test_undef is not set in config');
2113						}
2114	6	50			6	if($new) {
2115	0	0 0			0	if($status eq 'DIES') {
2116						$corpus_code .= "dies_ok { \$obj->$function($input_str) } " .
2117	0 0		0		0 0	"'$function(" . join(', ', map { $_ // '' } @$inputs ) . ") dies';\n";
2118						} elsif($status eq 'WARNS') {
2119						$corpus_code .= "warnings_exist { \$obj->$function($input_str) } qr/./, " .
2120	0 0		0		0 0	"'$function(" . join(', ', map { $_ // '' } @$inputs ) . ") warns';\n";
2121						} else {
2122						my $desc = sprintf("$function(%s) returns %s",
2123	0 0		0		0 0	perl_quote(join(', ', map { $_ // '' } @$inputs )),
2124						$expected_str
2125						);
2126	0	0	0		0	if(($output{'type'} // '') eq 'boolean') {
2127	0	0 0			0	if($expected_str eq '1') {
2128	0				0	$corpus_code .= "ok(\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
2129						} elsif($expected_str eq '0') {
2130	0				0	$corpus_code .= "ok(!\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
2131						} else {
2132	0				0	croak("Boolean is expected to return $expected_str");
2133						}
2134						} else {
2135	0				0	$corpus_code .= "is(\$obj->$function($input_str), $expected_str, " . q_wrap($desc) . ");\n";
2136						}
2137						}
2138						} else {
2139	6	50 50			11	if($status eq 'DIES') {
2140	0	0			0	if($module) {
2141	0				0	$corpus_code .= "dies_ok { $module\::$function($input_str) } " .
2142						"'Corpus $expected dies';\n";
2143						} else {
2144	0				0	$corpus_code .= "dies_ok { $function($input_str) } " .
2145						"'Corpus $expected dies';\n";
2146						}
2147						} elsif($status eq 'WARNS') {
2148	0	0			0	if($module) {
2149	0				0	$corpus_code .= "warnings_exist { $module\::$function($input_str) } qr/./, " .
2150						"'Corpus $expected warns';\n";
2151						} else {
2152	0				0	$corpus_code .= "warnings_exist { $function($input_str) } qr/./, " .
2153						"'Corpus $expected warns';\n";
2154						}
2155						} else {
2156						my $desc = sprintf("$function(%s) returns %s",
2157	6 9 6	50	50		14 13 6	perl_quote((ref $inputs eq 'ARRAY') ? (join(', ', map { $_ // '' } @{$inputs})) : $inputs),
2158						$expected_str
2159						);
2160	6	50	50		11	if(($output{'type'} // '') eq 'boolean') {
2161	0	0 0			0	if($expected_str eq '1') {
2162	0				0	$corpus_code .= "ok(\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
2163						} elsif($expected_str eq '0') {
2164	0				0	$corpus_code .= "ok(!\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
2165						} else {
2166	0				0	croak("Boolean is expected to return $expected_str");
2167						}
2168						} else {
2169	6				11	$corpus_code .= "is(\$obj->$function($input_str), $expected_str, " . q_wrap($desc) . ");\n";
2170						}
2171						}
2172						}
2173						}
2174						}
2175
2176						# Prepare seed/iterations code fragment for the generated test
2177	86				89	my $seed_code = '';
2178	86	100			105	if (defined $seed) {
2179						# ensure integer-ish
2180	7				10	$seed = int($seed);
2181	7				11	$seed_code = "srand($seed);\n";
2182						}
2183
2184	86	100			150	my $determinism_code = 'my $result2;' .
2185						'eval { $result2 = do { ' . (defined($position_code) ? $position_code : $call_code) . " }; };\n" .
2186						'is_deeply($result2, $result, "deterministic result for same input");' .
2187						"\n";
2188
2189						# Generate the test content
2190	86				531	my $tt = Template->new({ ENCODING => 'utf8', TRIM => 1 });
2191
2192						# Read template from DATA handle
2193	86				150736	my $template_package = __PACKAGE__ . '::Template';
2194	86				484	my $template = $template_package->get_data_section('test.tt');
2195
2196						my $vars = {
2197						setup_code => $setup_code,
2198						edge_cases_code => $edge_cases_code,
2199						edge_case_array_code => $edge_case_array_code,
2200						type_edge_cases_code => $type_edge_cases_code,
2201						config_code => $config_code,
2202						seed_code => $seed_code,
2203						input_code => $input_code,
2204						output_code => $output_code,
2205						transforms_code => $transforms_code,
2206						corpus_code => $corpus_code,
2207						call_code => $call_code,
2208						position_code => $position_code,
2209						determinism_code => $determinism_code,
2210						function => $function,
2211						iterations_code => int($iterations),
2212						use_properties => $use_properties,
2213						transform_properties_code => $transform_properties_code,
2214	86		67		99523	property_trials => $config{properties}{trials} // $DEFAULT_PROPERTY_TRIALS,
2215						relationships_code => $relationships_code,
2216						module => $module
2217						};
2218
2219	86				1085	my $test;
2220	86	50			200	$tt->process($template, $vars, \$test) or croak($tt->error());
2221
2222	86	100			1704487	if ($test_file) {
2223						# autodie is disabled for this open -- under "use autodie qw(:all)"
2224						# open() never returns false on failure, it throws its own exception
2225						# instead, which would silently make the "or croak" dead code.
2226	22 22 22			22	91 20 78	no autodie qw(open);
2227	31	50			1386	open my $fh, '>:encoding(UTF-8)', $test_file or croak "Cannot open $test_file: $!";
2228	31				15476	print $fh "$test\n";
2229	31				129	close $fh;
2230	31	100			5172	if($module) {
2231	18				312	print "Generated $test_file for $module\::$function with fuzzing + corpus support\n";
2232						} else {
2233	13				250	print "Generated $test_file for $function with fuzzing + corpus support\n";
2234						}
2235						} else {
2236	55				59536	print "$test\n";
2237						}
2238						}
2239
2240						# --- Helpers for rendering data structures into Perl code for the generated test ---
2241
2242						# --------------------------------------------------
2243						# _is_perl_builtin
2244						#
2245						# Purpose: Return true if a string is the name of
2246						# a Perl core builtin function, to prevent
2247						# it being used as a module name in
2248						# use_ok() calls in generated tests.
2249						#
2250						# Entry: $name - the string to check.
2251						# Exit: Returns 1 if builtin, 0 otherwise.
2252						# --------------------------------------------------
2253						sub _is_perl_builtin {
2254	34			34	12649	my $name = $_[0];
2255	34	100			42	return 0 unless defined $name;
2256
2257	32 404				29 458	state %BUILTINS = map { $_ => 1 } qw(
2258						abs accept alarm atan2 bind binmode bless
2259						caller chdir chmod chomp chop chown chr chroot
2260						close closedir connect cos crypt
2261						dbmclose dbmopen defined delete die do dump
2262						each endgrent endhostent endnetent endprotoent endpwent endservent
2263						eof eval exec exists exit exp
2264						fcntl fileno flock fork format formline
2265						getc getgrent getgrgid getgrnam gethostbyaddr gethostbyname
2266						gethostent getlogin getnetbyaddr getnetbyname getnetent
2267						getpeername getpgrp getppid getpriority getprotobyname
2268						getprotobynumber getprotoent getpwent getpwnam getpwuid
2269						getservbyname getservbyport getservent getsockname getsockopt
2270						glob gmtime goto grep
2271						hex
2272						index int ioctl
2273						join
2274						keys kill
2275						last lc lcfirst length link listen local localtime log lstat
2276						map mkdir msgctl msgget msgrcv msgsnd my
2277						next no
2278						oct open opendir ord our
2279						pack pipe pop pos print printf prototype push
2280						quotemeta
2281						rand read readdir readline readlink readpipe recv redo
2282						ref rename require reset return reverse rewinddir rindex rmdir
2283						say scalar seek seekdir select semctl semget semop send
2284						setgrent sethostent setnetent setpgrp setpriority setprotoent
2285						setpwent setservent setsockopt shift shmctl shmget shmread
2286						shmwrite shutdown sin sleep socket socketpair sort splice split
2287						sprintf sqrt srand stat study sub substr symlink syscall
2288						sysopen sysread sysseek system syswrite
2289						tell telldir tie tied time times truncate
2290						uc ucfirst umask undef unlink unpack unshift untie use
2291						utime values vec wait waitpid wantarray warn write
2292						);
2293	32		100		117	return $BUILTINS{lc $name} // 0;
2294						}
2295
2296						# --------------------------------------------------
2297						# _load_schema
2298						#
2299						# Load and parse a schema file using
2300						# Config::Abstraction, returning the
2301						# schema as a hashref.
2302						#
2303						# Entry: $schema_file - path to the schema file.
2304						# Must be defined, non-empty, and readable.
2305						#
2306						# Exit: Returns a hashref of the parsed schema
2307						# with a '_source' key added containing
2308						# the originating file path.
2309						# Croaks on any error.
2310						#
2311						# Side effects: Reads from the filesystem.
2312						#
2313						# Notes: Legacy Perl-file configs (containing
2314						# '$module' or 'our $module' keys) are
2315						# rejected with a clear error. Config::
2316						# Abstraction is used rather than require()
2317						# to avoid executing arbitrary code from
2318						# user-supplied config files.
2319						# --------------------------------------------------
2320						sub _load_schema {
2321	102			102	8477	my $schema_file = $_[0];
2322
2323						# Validate the argument before touching the filesystem
2324	102	100			166	croak(__PACKAGE__, ': Usage: _load_schema($schema_file)') unless defined $schema_file;
2325
2326	100	100			158	croak(__PACKAGE__, ': _load_schema given empty filename') unless length($schema_file);
2327
2328						# Confirm the file exists and is readable before attempting
2329						# to load it â€” gives a clearer error than Config::Abstraction would
2330	98	100			656	croak(__PACKAGE__, ": _load_schema($schema_file): $!") unless -r $schema_file;
2331
2332						# Load configuration via Config::Abstraction which supports
2333						# YAML, JSON, and other formats without executing arbitrary code.
2334						# no_fixate prevents automatic type coercion that could alter values
2335	93	50			559	if(my $schema = Config::Abstraction->new(
2336						config_dirs => ['.', ''],
2337						config_file => $schema_file,
2338						no_fixate => 1,
2339						)) {
2340	93	50			155985	if($schema = $schema->all()) {
2341						# Detect legacy Perl config files by the presence of
2342						# variable declaration keys â€” these are no longer supported
2343	93	100	67		1008	if(exists($schema->{$LEGACY_PERL_KEY_1}) \|\|
2344						exists($schema->{$LEGACY_PERL_KEY_2})) {
2345	1				8	croak("$schema_file: Loading perl files as configs is no longer supported");
2346						}
2347
2348						# Tag the schema with its source path for error messages
2349	92				778	$schema->{$SOURCE_KEY} = $schema_file;
2350	92				612	return $schema;
2351						}
2352						}
2353
2354	0				0	croak "Failed to load schema from $schema_file";
2355						}
2356
2357						# --------------------------------------------------
2358						# _load_schema_section
2359						#
2360						# Purpose: Extract a named section from a parsed
2361						# schema hashref, validating that it is
2362						# a hashref if present.
2363						#
2364						# Entry: $schema - the full parsed schema hashref.
2365						# $section - name of the section to extract
2366						# (e.g. 'input', 'output').
2367						# $schema_file - path of the schema file,
2368						# used in error messages only.
2369						#
2370						# Exit: Returns the section hashref if present,
2371						# or an empty hashref {} if absent.
2372						# Croaks if the section exists but is not
2373						# a hashref (and not the string 'undef').
2374						#
2375						# Notes: The string 'undef' is treated as an
2376						# absent section â€” callers that set a
2377						# section to 'undef' in YAML get the same
2378						# result as omitting it entirely.
2379						# --------------------------------------------------
2380						sub _load_schema_section {
2381	398			398	6456	my ($schema, $section, $schema_file) = @_;
2382
2383						# Section absent â€” return empty hash as the safe default
2384	398	100			527	return {} unless exists $schema->{$section};
2385
2386						# Section present and is a hashref â€” return it directly
2387						return $schema->{$section}
2388	203	100			560	if ref($schema->{$section}) eq 'HASH';
2389
2390						# Treat the YAML scalar 'undef' as equivalent to absent
2391						return {}
2392						if defined($schema->{$section}) &&
2393	8	100	67		22	$schema->{$section} eq 'undef';
2394
2395						# Section present but wrong type â€” croak with a clear message
2396						# showing what type was found so the user can fix their schema
2397						croak(
2398						"$schema_file: $section should be a hash, not ",
2399	5		67		39	ref($schema->{$section}) \|\| $schema->{$section}
2400						);
2401						}
2402
2403						# --------------------------------------------------
2404						# _validate_config
2405						#
2406						# Purpose: Validate the top-level schema hashref
2407						# loaded from a schema file, checking that
2408						# required fields are present and that all
2409						# input parameters, types, positions, and
2410						# transform properties are well-formed.
2411						#
2412						# Entry: $schema - the full parsed schema hashref
2413						# as returned by _load_schema().
2414						#
2415						# Exit: Returns nothing on success.
2416						# Croaks on any structural error.
2417						# Carps on non-fatal warnings (unknown
2418						# semantic types, position gaps, missing
2419						# input/output definitions).
2420						#
2421						# Side effects: May delete $schema->{input} if its
2422						# value is the string 'undef'.
2423						#
2424						# Notes: The parameter is named $schema throughout
2425						# to distinguish the top-level schema from
2426						# the nested config sub-hash. _validate_config
2427						# is called before _normalize_config so config
2428						# boolean normalisation has not yet occurred.
2429						# --------------------------------------------------
2430						sub _validate_config {
2431	111			111	29286	my $schema = $_[0];
2432
2433						# At least one of module or function must be present â€”
2434						# without these we cannot generate any meaningful test
2435	111	100	100		240	if(!defined($schema->{'module'}) && !defined($schema->{'function'})) {
2436	4				23	croak('At least one of function and module must be defined');
2437						}
2438
2439						# Warn if neither input nor output is defined â€” a few
2440						# generic tests can still be generated but it is unusual
2441	107	100	100		192	if(!defined($schema->{'input'}) && !defined($schema->{'output'})) {
2442	9				61	carp('Neither input nor output is defined, only a few tests will be generated');
2443						}
2444
2445						# Normalise input: the string 'undef' means no input defined
2446	107	100	100		1489	if($schema->{'input'} && ref($schema->{input}) ne 'HASH') {
2447	3	100			5	if($schema->{'input'} eq 'undef') {
2448	1				1	delete $schema->{'input'};
2449						} else {
2450	2				10	croak("Invalid input specification: expected hash, got '$schema->{'input'}'");
2451						}
2452						}
2453
2454						# Validate each input parameter if input is defined
2455	105	100			145	if($schema->{input}) {
2456	91				180	_validate_input_params($schema);
2457	90				199	_validate_input_positions($schema);
2458	90				138	_validate_input_semantics($schema);
2459						}
2460
2461						# Validate transform property definitions if present
2462	104	100	67		248	if(exists($schema->{transforms}) && ref($schema->{transforms}) eq 'HASH') {
2463	11				23	_validate_transform_properties($schema);
2464						}
2465
2466						# Validate any nested config sub-hash keys against known types
2467	104	100			193	if(ref($schema->{config}) eq 'HASH') {
2468	12 12				13 23	for my $k (keys %{$schema->{'config'}}) {
2469						# %VALID_CONFIG_KEYS is the authoritative set â€” O(1) hash lookup
2470						croak "unknown config setting '$k'"
2471	49	100			187	unless $VALID_CONFIG_KEYS{$k};
2472						}
2473						}
2474						}
2475
2476						# --------------------------------------------------
2477						# _validate_input_params
2478						#
2479						# Purpose: Validate type specifications for each
2480						# named input parameter.
2481						#
2482						# Entry: $schema - the full parsed schema hashref.
2483						# $schema->{input} must be a hashref.
2484						#
2485						# Exit: Returns nothing. Croaks on invalid type.
2486						# --------------------------------------------------
2487						sub _validate_input_params {
2488	94			94	4996	my $schema = $_[0];
2489
2490	94 94				81 179	for my $param (keys %{$schema->{input}}) {
2491						# Catch empty parameter names â€” these would produce
2492						# broken Perl variable names in the generated test
2493	95	100			127	croak 'Empty input parameter name'
2494						unless length($param);
2495
2496	94				114	my $spec = $schema->{input}{$param};
2497
2498						# Validate the type field â€” required for all parameters
2499	94	100			113	if(ref($spec)) {
2500						croak("Missing type for parameter '$param'")
2501	41	100			66	unless defined $spec->{type};
2502						# 'coderef' is a SchemaExtractor-specific type; treat as 'any'
2503	40	50			62	$spec->{type} = 'any' if $spec->{type} eq 'coderef';
2504						croak("Invalid type '$spec->{type}' for parameter '$param'")
2505	40	100			82	unless _valid_type($spec->{type});
2506						} else {
2507	53	50			100	croak("Invalid type '$spec' for parameter '$param'")
2508						unless _valid_type($spec);
2509						}
2510						}
2511						}
2512
2513						# --------------------------------------------------
2514						# _validate_input_positions
2515						#
2516						# Purpose: Validate positional argument declarations
2517						# in the input schema â€” positions must be
2518						# non-negative integers with no duplicates,
2519						# and either all or no parameters must have
2520						# positions.
2521						#
2522						# Entry: $schema - the full parsed schema hashref.
2523						# $schema->{input} must be a hashref.
2524						#
2525						# Exit: Returns nothing. Croaks on invalid or
2526						# duplicate positions. Carps on gaps.
2527						# --------------------------------------------------
2528						sub _validate_input_positions {
2529	98			98	7558	my $schema = $_[0];
2530
2531	98				118	my $has_positions = 0;
2532	98				79	my %positions;
2533
2534	98 98				99 191	for my $param (keys %{$schema->{input}}) {
2535	105				116	my $spec = $schema->{input}{$param};
2536
2537						# Only process params that explicitly declare a position
2538	105	100	100		236	next unless ref($spec) eq 'HASH' && defined($spec->{position});
2539
2540	31				28	$has_positions = 1;
2541	31				26	my $pos = $spec->{position};
2542
2543						# Position must be a non-negative integer
2544	31	100			82	croak "Position for '$param' must be a non-negative integer"
2545						unless $pos =~ /^\d+$/;
2546
2547						# Duplicate positions would produce ambiguous generated tests
2548						croak "Duplicate position $pos for parameters '$positions{$pos}' and '$param'"
2549	30	100			45	if exists $positions{$pos};
2550
2551	28				41	$positions{$pos} = $param;
2552						}
2553
2554						# If any param has a position, all params must have one
2555	95	100			160	if($has_positions) {
2556	19 19				41 32	for my $param (keys %{$schema->{input}}) {
2557	27				26	my $spec = $schema->{input}{$param};
2558	27	100	67		69	unless(ref($spec) eq 'HASH' && defined($spec->{position})) {
2559	2				10	croak "Parameter '$param' missing position " .
2560						'(all params must have positions if any do)';
2561						}
2562						}
2563
2564						# Check for gaps â€” positions must be a contiguous sequence
2565						# starting at 0, otherwise the generated test will be wrong
2566	17 7				46 17	my @sorted = sort { $a <=> $b } keys %positions;
2567	17				30	for my $i (0 .. $#sorted) {
2568	24	100			54	if($sorted[$i] != $i) {
2569	1				5	carp "Position sequence has gaps (positions: @sorted)";
2570	1				135	last;
2571						}
2572						}
2573						}
2574						}
2575
2576						# --------------------------------------------------
2577						# _validate_input_semantics
2578						#
2579						# Purpose: Validate semantic type annotations and
2580						# enum/memberof constraints on input params.
2581						#
2582						# Entry: $schema - the full parsed schema hashref.
2583						# $schema->{input} must be a hashref.
2584						#
2585						# Exit: Returns nothing. Croaks on conflicting
2586						# or malformed enum/memberof. Carps on
2587						# unknown semantic types.
2588						# --------------------------------------------------
2589						sub _validate_input_semantics {
2590	100			100	11166	my $schema = $_[0];
2591
2592	100				190	my $semantic_generators = _get_semantic_generators();
2593
2594	100 100				81 206	for my $param (keys %{$schema->{input}}) {
2595	100				102	my $spec = $schema->{input}{$param};
2596	100	100			345	next unless ref($spec) eq 'HASH';
2597
2598						# Warn on unknown semantic types rather than croaking â€”
2599						# new semantic types may be added without updating this list
2600	46	100			63	if(defined($spec->{semantic})) {
2601	4				2	my $semantic = $spec->{semantic};
2602	4	100			6	unless(exists $semantic_generators->{$semantic}) {
2603						carp "Unknown semantic type '$semantic' for parameter '$param'. " .
2604						'Available types: ' .
2605	2 2				4 20	join(', ', sort keys %{$semantic_generators});
2606						}
2607						}
2608
2609						# enum and memberof are mutually exclusive representations
2610						# of the same concept â€” having both is always a schema error
2611	46	100	100		284	if($spec->{'enum'} && $spec->{'memberof'}) {
2612	2				8	croak "$param: has both enum and memberof";
2613						}
2614
2615						# Both enum and memberof must be arrayrefs when present
2616	44				51	for my $type ('enum', 'memberof') {
2617	87	100			241	if(exists $spec->{$type}) {
2618						croak "$type must be an arrayref"
2619	4	100			37	unless ref($spec->{$type}) eq 'ARRAY';
2620						}
2621						}
2622						}
2623						}
2624
2625						# --------------------------------------------------
2626						# _validate_transform_properties
2627						#
2628						# Purpose: Validate the properties array in each
2629						# transform definition, checking that each
2630						# property is either a known builtin name
2631						# or a custom hashref with name and code.
2632						#
2633						# Entry: $schema - the full parsed schema hashref.
2634						# $schema->{transforms} must be a hashref.
2635						#
2636						# Exit: Returns nothing. Croaks on invalid property
2637						# definitions. Carps on unknown builtins.
2638						# --------------------------------------------------
2639						sub _validate_transform_properties {
2640	17			17	8460	my $schema = $_[0];
2641
2642	17				39	my $builtin_props = _get_builtin_properties();
2643
2644	17 17				16 111	for my $transform_name (keys %{$schema->{transforms}}) {
2645	15				15	my $transform = $schema->{transforms}{$transform_name};
2646
2647						# properties is optional â€” skip transforms that don't define it
2648	15	100			91	next unless exists $transform->{properties};
2649
2650						croak "Transform '$transform_name': properties must be an array"
2651	6	100			10	unless ref($transform->{properties}) eq 'ARRAY';
2652
2653	5 5				4 4	for my $prop (@{$transform->{properties}}) {
2654	5	100 100			8	if(!ref($prop)) {
2655						# Plain string â€” must be a known builtin property name
2656	2	100			14	unless(exists $builtin_props->{$prop}) {
2657						carp "Transform '$transform_name': unknown built-in property '$prop'. " .
2658						'Available: ' .
2659	1 1				2 8	join(', ', sort keys %{$builtin_props});
2660						}
2661						} elsif(ref($prop) eq 'HASH') {
2662						# Custom property â€” must have both name and code fields
2663	2	100	67		15	unless($prop->{name} && $prop->{code}) {
2664	1				4	croak "Transform '$transform_name': " .
2665						"custom properties must have 'name' and 'code' fields";
2666						}
2667						} else {
2668	1				5	croak "Transform '$transform_name': invalid property definition";
2669						}
2670						}
2671						}
2672						}
2673
2674						# --------------------------------------------------
2675						# _normalize_config
2676						#
2677						# Purpose: Normalise boolean string values in the
2678						# config sub-hash to Perl integers (1/0),
2679						# and default absent boolean fields to 1
2680						# (enabled). The 'properties' field is a
2681						# hashref not a boolean and is handled
2682						# separately.
2683						#
2684						# Entry: $config - the config sub-hash extracted
2685						# from the schema (i.e. $schema->{config}).
2686						# May be empty.
2687						#
2688						# Exit: Returns nothing. Modifies $config in place.
2689						#
2690						# Side effects: Modifies the caller's config hashref.
2691						#
2692						# Notes: String-to-boolean conversion is delegated
2693						# to %Readonly::Values::Boolean::booleans
2694						# which handles 'yes'/'no', 'on'/'off',
2695						# 'true'/'false' etc. Fields not present in
2696						# the config hash are defaulted to 1 so
2697						# that test generation is maximally thorough
2698						# unless the schema explicitly disables a
2699						# feature.
2700						# --------------------------------------------------
2701						sub _normalize_config {
2702	102			102	12879	my $config = $_[0];
2703
2704	102				342	for my $field (keys %VALID_CONFIG_KEYS) {
2705						# Non-boolean fields are handled separately
2706	918	100			2719	next if $field eq $CONFIG_PROPERTIES_KEY;
2707	816	100			1659	next if $field eq 'timeout'; # numeric, not boolean; absence means use generated-test default
2708
2709	714	100	100		889	if(exists($config->{$field}) && defined($config->{$field})) {
2710						# Convert string boolean representations to integers
2711						# using the lookup table from Readonly::Values::Boolean
2712	530	50			731	if(defined(my $b = $Readonly::Values::Boolean::booleans{$config->{$field}})) {
2713	530				1646	$config->{$field} = $b;
2714						}
2715						} else {
2716						# Default absent boolean fields to enabled (1) so that
2717						# test generation is comprehensive unless explicitly disabled
2718	184				163	$config->{$field} = 1;
2719						}
2720						}
2721
2722						# Ensure properties is always a hashref â€” if absent or set to
2723						# a non-hash value, replace with a disabled default so that
2724						# downstream code can safely dereference it without checking ref()
2725	102	100			214	$config->{$CONFIG_PROPERTIES_KEY} = { enable => 0 } unless ref($config->{$CONFIG_PROPERTIES_KEY}) eq 'HASH';
2726						}
2727
2728						# --------------------------------------------------
2729						# _valid_type
2730						#
2731						# Determine whether a string is a
2732						# recognised schema field type accepted
2733						# by the generator.
2734						#
2735						# Entry: $type - the type string to validate.
2736						# May be undef.
2737						#
2738						# Exit: Returns 1 if the type is known,
2739						# 0 if the type is unknown or undef.
2740						#
2741						# Notes: The lookup hash is declared with
2742						# 'state' so it is built only once per
2743						# process rather than on every call â€”
2744						# important since _valid_type is called
2745						# in a loop over all input parameters.
2746						#
2747						# 'int' and 'bool' are accepted as
2748						# aliases for 'integer' and 'boolean'
2749						# respectively, for compatibility with
2750						# schemas generated by external tools
2751						# that use the shorter forms.
2752						# --------------------------------------------------
2753						sub _valid_type {
2754	154			154	18958	my $type = $_[0];
2755
2756						# Undef is never a valid type
2757	154	100			197	return 0 unless defined($type);
2758
2759						# Build the lookup table once and cache it for
2760						# the lifetime of the process via 'state'
2761	151 165				171 239	state %VALID = map { $_ => 1 } qw(
2762						string boolean integer number float
2763						hashref arrayref object int bool any
2764						);
2765
2766	151		100		411	return($VALID{$type} // 0);
2767						}
2768
2769						# --------------------------------------------------
2770						# _assert_identifier
2771						#
2772						# Purpose: Validate that a string is shaped like a
2773						# plain Perl identifier (or, with
2774						# package => 1, a "::"-separated package
2775						# name) before it is spliced into generated
2776						# test source as a bareword, package name,
2777						# method name, or variable name rather than
2778						# a quoted string literal. Schema-derived
2779						# names (module, function, transform names)
2780						# are spliced unescaped at the call sites
2781						# that use this guard, so an unvalidated
2782						# name could otherwise break out of the
2783						# generated source and inject arbitrary
2784						# Perl into a file that L<prove> will run.
2785						#
2786						# Entry: $name - the string to validate.
2787						# $what - short label for the value, used
2788						# only in the croak message.
2789						# %opts - package => 1 allows "::"
2790						# separators in $name.
2791						#
2792						# Exit: Returns $name unchanged on success.
2793						# Croaks if $name is not identifier-shaped.
2794						# --------------------------------------------------
2795						sub _assert_identifier {
2796	165			165	10414	my ($name, $what, %opts) = @_;
2797
2798	165	100	100		340	croak(__PACKAGE__, ": $what is missing or empty")
2799						unless defined($name) && length($name);
2800
2801						my $re = $opts{package}
2802	163	100			389	? qr/^[A-Za-z_]\w(?:::[A-Za-z_]\w)*\z/
2803						: qr/^[A-Za-z_]\w*\z/;
2804
2805	163	100			660	croak(__PACKAGE__, ": $what '$name' is not a valid Perl identifier")
2806						unless $name =~ $re;
2807
2808	153				243	return $name;
2809						}
2810
2811						# --------------------------------------------------
2812						# _validate_module
2813						#
2814						# Purpose: Check whether the module named in a
2815						# schema can be found in @INC during
2816						# test generation. Optionally also
2817						# attempts to load it if the
2818						# GENERATOR_VALIDATE_LOAD environment
2819						# variable is set.
2820						#
2821						# Entry: $module - the module name to
2822						# check. If undef or
2823						# empty, returns 1
2824						# immediately (builtin
2825						# functions need no
2826						# module).
2827						# $schema_file - path to the schema
2828						# file, used in warning
2829						# messages only.
2830						#
2831						# Exit: Returns 1 if the module was found
2832						# (and loaded, if validation was
2833						# requested).
2834						# Returns 0 if the module was not
2835						# found or failed to load â€” this is
2836						# non-fatal; generation continues.
2837						# Returns 1 immediately for undef or
2838						# empty $module.
2839						#
2840						# Side effects: Prints to STDERR when TEST_VERBOSE
2841						# or GENERATOR_VERBOSE is set.
2842						# Carps (non-fatally) when the module
2843						# cannot be found or loaded.
2844						# May attempt to load the module into
2845						# the current process when
2846						# GENERATOR_VALIDATE_LOAD is set â€”
2847						# this can have side effects depending
2848						# on the module.
2849						#
2850						# Notes: Not finding a module during generation
2851						# is intentionally non-fatal â€” the module
2852						# may be available on the target machine
2853						# even if not on the generation machine.
2854						# Verbose output goes to STDERR via
2855						# print rather than carp since it is
2856						# informational, not a warning.
2857						# --------------------------------------------------
2858						sub _validate_module {
2859	43			43	8101	my ($module, $schema_file) = @_;
2860
2861						# Builtin functions have no module to validate
2862	43	100			52	return 1 unless $module;
2863
2864						# Check whether the module is findable in @INC
2865	41				128	my $mod_info = check_install(module => $module);
2866
2867	41	100	100		65235	if($schema_file && !$mod_info) {
2868						# Non-fatal â€” emit a single consolidated warning so
2869						# the caller sees one message rather than four
2870	18				425	carp(
2871						"Module '$module' not found in \@INC during generation.\n" .
2872						" Config file: $schema_file\n" .
2873						" This is OK if the module will be available when tests run.\n" .
2874						' If unexpected, check your module name and installation.'
2875						);
2876	18				2729	return 0;
2877						}
2878
2879						# Check once and reuse â€” avoids evaluating two env vars twice
2880	23		33		61	my $verbose = $ENV{$ENV_TEST_VERBOSE} \|\| $ENV{$ENV_GENERATOR_VERBOSE};
2881
2882	23	50			185	if($verbose) {
2883						carp "Found module '$module' at: $mod_info->{'file'} " .
2884	0		0		0	'(version ' . ($mod_info->{'version'} \|\| 'unknown') . ')';
2885						}
2886
2887						# Optional load validation â€” disabled by default because
2888						# loading a module can have side effects (e.g. BEGIN blocks,
2889						# database connections, file I/O) that are undesirable
2890						# during generation
2891	23	100			37	if($ENV{$ENV_VALIDATE_LOAD}) {
2892	1				9	my $loaded = can_load(modules => { $module => undef }, verbose => 0);
2893
2894	1	50			5753	if(!$loaded) {
2895	0		0		0	my $err = $Module::Load::Conditional::ERROR \|\| 'unknown error';
2896	0				0	carp(
2897						"Module '$module' found but failed to load: $err\n" .
2898						' This might indicate a broken installation or missing dependencies.'
2899						);
2900	0				0	return 0;
2901						}
2902
2903	1	50			2	if($verbose) {
2904	0				0	carp "Successfully loaded module '$module'";
2905						}
2906						}
2907
2908	23				97	return 1;
2909						}
2910
2911 - 2957						=head2 render_fallback Render any Perl value into a compact Perl source-code string using L<Data::Dumper>. Used as a catch-all when no more specific renderer applies. my $code = render_fallback({ key => 'value' }); # returns: "{'key' => 'value'}" =head3 Arguments =over 4 =item * C<$v> Any Perl value, including undef, scalars, refs, and blessed objects. =back =head3 Returns A string of Perl source code that reproduces the value when evaluated. Returns the string C<'undef'> when C<$v> is undef. =head3 Side effects Temporarily sets C<$Data::Dumper::Terse> and C<$Data::Dumper::Indent> to produce compact single-line output. Both are restored on return via C<local>. =head3 Notes The output is always a single line with no trailing newline. Suitable for embedding in generated test code where readability is secondary to correctness. =head3 API specification =head4 input { v => { type => 'any', optional => 1 } } =head4 output { type => 'string' } =cut
2958
2959						sub render_fallback {
2960	38			38	7515	my $v = $_[0];
2961
2962						# Handle undef explicitly rather than letting Dumper produce
2963						# 'undef' without the localised settings applied
2964	38	100			51	return 'undef' unless defined $v;
2965
2966						# Use Terse+Indent=0 to produce compact single-line output
2967						# suitable for embedding in generated test code
2968	28				44	local $Data::Dumper::Terse = 1;
2969	28				53	local $Data::Dumper::Indent = 0;
2970
2971	28				92	my $s = Dumper($v);
2972
2973						# Remove trailing newline that Dumper always appends
2974	28				1072	chomp $s;
2975	28				60	return $s;
2976						}
2977
2978 - 3028						=head2 render_hash Render a two-level hashref (parameter name => spec hashref) into Perl source code suitable for embedding in a generated test file as the input specification passed to L<Params::Validate::Strict>. my $code = render_hash(\%input); =head3 Arguments =over 4 =item * C<$href> A hashref whose values are themselves hashrefs containing field specifications. A scalar value that is a recognised type string (see C<_valid_type>) is expanded to C<{ type =E<gt> $value }>. Any other non-hashref value is skipped with a warning. =back =head3 Returns A string of comma-separated Perl source-code lines, one per key, of the form: 'key' => { subkey => value, ... } Returns an empty string if C<$href> is undef, empty, or not a hashref. =head3 Notes The C<matches> and C<nomatch> sub-keys are treated specially â€” their values are compiled to C<Regexp> objects via C<eval { qr/.../ }> and then rendered using C<perl_quote> so they appear as C<qr{...}> in the generated test. This prevents unmatched bracket characters in the pattern from causing compilation failures. Other sub-keys are rendered via C<perl_quote>. =head3 API specification =head4 input { href => { type => 'any', optional => 1 } } =head4 output { type => 'string' } =cut
3029
3030						sub render_hash {
3031	58			58	19411	my $href = $_[0];
3032
3033						# Return empty string for absent or non-hash input â€” callers
3034						# treat '' as "no input specification" in the generated test
3035	58	100	100		162	return '' unless $href && ref($href) eq 'HASH';
3036
3037	53				38	my @lines;
3038
3039	53 53				51 82	for my $k (sort keys %{$href}) {
3040	44				49	my $def = $href->{$k};
3041
3042						# Handle scalar shorthand â€” 'arg1: string' is equivalent to
3043						# 'arg1: { type: string }' and is explicitly supported by the
3044						# validation layer in _validate_input_params
3045	44	100	67		116	unless(defined($def) && ref($def) eq 'HASH') {
3046	6	100	50		23	if(defined($def) && !ref($def) && _valid_type($def)) {
3047						# Expand scalar type shorthand to a full spec hashref
3048	4				6	$def = { type => $def };
3049						} else {
3050	2				20	carp "render_hash: skipping key '$k' â€” value is not a hashref or recognised type string";
3051	2				210	next;
3052						}
3053						}
3054
3055	42				35	my @pairs;
3056
3057	42 42				34 78	for my $subk (sort keys %{$def}) {
3058						# Skip undef sub-values â€” they contribute nothing to the spec
3059	85	100			128	next unless defined $def->{$subk};
3060
3061						# Validate that reference types are ones we can render â€”
3062						# nested hashrefs are not yet supported
3063	84	50			90	if(ref($def->{$subk})) {
3064	0	0	0		0	unless((ref($def->{$subk}) eq 'ARRAY') \|\|
3065						(ref($def->{$subk}) eq 'Regexp')) {
3066						croak(
3067						__PACKAGE__,
3068						": $subk is a nested element, not yet supported (",
3069	0				0	ref($def->{$subk}), ')'
3070						);
3071						}
3072						}
3073
3074						# matches and nomatch values must be Regexp objects in the
3075						# generated test â€” compile raw strings safely via eval so
3076						# patterns containing [ or \ don't cause compile failures
3077	84	100	67		145	if(($subk eq $KEY_MATCHES) \|\| ($subk eq $KEY_NOMATCH)) {
3078						my $re = ref($def->{$subk}) eq 'Regexp'
3079						? $def->{$subk}
3080	3 3	50			15 32	: eval { qr/$def->{$subk}/ };
3081	3	50	33		10	if($@ \|\| !defined($re)) {
3082	0				0	carp "render_hash: invalid $subk pattern '$def->{$subk}': $@";
3083	0				0	next;
3084						}
3085	3				7	push @pairs, "$subk => " . perl_quote($re);
3086						} else {
3087						# All other sub-keys are rendered via perl_quote which
3088						# handles scalars, arrayrefs, and Regexp objects correctly
3089	81				444	push @pairs, "$subk => " . perl_quote($def->{$subk});
3090						}
3091						}
3092
3093						# Use "\t" rather than a literal tab for clarity and grep-ability
3094	42				49	push @lines, "\t" . perl_quote($k) . ' => { ' . join(', ', @pairs) . ' }';
3095						}
3096
3097	53				101	return join(",\n", @lines);
3098						}
3099
3100 - 3142						=head2 render_args_hash Render a flat hashref into a Perl source-code argument list of the form C<'key' => value, ...>, suitable for embedding in a function call in a generated test file. my $code = render_args_hash({ type => 'string', min => 1 }); # returns: "'min' => 1, 'type' => 'string'" =head3 Arguments =over 4 =item * C<$href> A flat hashref of key-value pairs. Values may be scalars, arrayrefs, or Regexp objects â€” all are handled by C<perl_quote>. =back =head3 Returns A comma-separated string of C<key => value> pairs sorted by key. Returns an empty string if C<$href> is undef, empty, or not a hashref. =head3 Notes Keys and values are both rendered via C<perl_quote>. In particular, C<Regexp> values are rendered as C<qr{...}> which is correct for L<Params::Validate::Strict> and L<Return::Set> schema arguments in the generated test. =head3 API specification =head4 input { href => { type => 'any', optional => 1 } } =head4 output { type => 'string' } =cut
3143
3144						sub render_args_hash {
3145	126			126	11666	my $href = $_[0];
3146
3147						# Return empty string for absent or non-hash input
3148	126	100	100		297	return '' unless $href && ref($href) eq 'HASH';
3149
3150						# Sort keys for deterministic output across runs â€” important for
3151						# generated test files that are committed to version control
3152						my @pairs = map {
3153	141				149	perl_quote($_) . ' => ' . perl_quote($href->{$_})
3154	122 122				100 186	} sort keys %{$href};
3155
3156	122				225	return join(', ', @pairs);
3157						}
3158
3159 - 3201						=head2 render_arrayref_map Render a hashref whose values are arrayrefs into a Perl source-code fragment suitable for use as a hash literal in a generated test file. my $code = render_arrayref_map({ name => ['', 'a' x 100] }); =head3 Arguments =over 4 =item * C<$href> A hashref whose values are arrayrefs. Keys whose values are not arrayrefs are silently skipped. =back =head3 Returns A comma-separated string of C<'key' => [ val, ... ]> entries, one per qualifying key, sorted alphabetically. Returns the string C<'()'> if C<$href> is undef, empty, or not a hashref â€” this produces an empty hash assignment in the generated test rather than a syntax error. =head3 Notes Array element values are rendered via C<perl_quote> which handles scalars, arrayrefs, and Regexp objects. Non-arrayref values are skipped without warning â€” this is intentional since callers may pass mixed-value hashes and only want the arrayref entries rendered. =head3 API specification =head4 input { href => { type => 'any', optional => 1 } } =head4 output { type => 'string' } =cut
3202
3203						sub render_arrayref_map {
3204	191			191	13613	my $href = $_[0];
3205
3206						# Return '()' rather than '' so callers get a valid empty hash
3207						# literal rather than a syntax error in the generated test
3208	191	100	67		379	return '()' unless $href && ref($href) eq 'HASH';
3209
3210	188				142	my @entries;
3211
3212	188 188				157 234	for my $k (sort keys %{$href}) {
3213	10				12	my $aref = $href->{$k};
3214
3215						# Skip non-arrayref values â€” mixed hashes are allowed by callers
3216	10	100			15	next unless ref($aref) eq 'ARRAY';
3217
3218						# Render each array element via perl_quote so strings are
3219						# properly quoted and numbers are left unquoted
3220	7 12 7				6 12 7	my $vals = join(', ', map { perl_quote($_) } @{$aref});
3221
3222						# Use "\t" rather than a literal tab for clarity
3223	7				10	push @entries, "\t" . perl_quote($k) . " => [ $vals ]";
3224						}
3225
3226	188				290	return join(",\n", @entries);
3227						}
3228
3229						# --------------------------------------------------
3230						# _has_positions
3231						#
3232						# Purpose: Determine whether any field in an input
3233						# spec hashref declares a positional argument
3234						# via the 'position' key.
3235						#
3236						# Entry: $input_spec - the input section of a parsed
3237						# schema, expected to be a hashref whose values
3238						# are themselves hashrefs containing field specs.
3239						# May be undef or a non-hash ref.
3240						#
3241						# Exit: Returns 1 if any field has a defined
3242						# 'position' key, 0 otherwise.
3243						#
3244						# Notes: Returns 0 immediately for undef or non-hash
3245						# input rather than throwing â€” callers use the
3246						# return value as a boolean and do not expect
3247						# exceptions from this function.
3248						# --------------------------------------------------
3249						sub _has_positions {
3250	113			113	14059	my $input_spec = $_[0];
3251
3252						# Guard against undef or non-hash input â€” keys %$undef would throw
3253	113	100	100		259	return 0 unless defined($input_spec) && ref($input_spec) eq 'HASH';
3254
3255	109 109				89 130	for my $field (keys %{$input_spec}) {
3256						# Only examine fields whose spec is a hashref â€” scalar specs
3257						# (e.g. input: { type: string }) cannot have positions
3258	96	100			183	next unless ref($input_spec->{$field}) eq 'HASH';
3259
3260						# Return immediately on first match â€” no need to scan further
3261	43	100			74	return 1 if defined $input_spec->{$field}{position};
3262						}
3263
3264						# No positional arguments found in any field
3265	82				98	return 0;
3266						}
3267
3268						# --------------------------------------------------
3269						# q_wrap
3270						#
3271						# Purpose: Wrap a string in the most readable
3272						# q{} form that does not require escaping,
3273						# falling back to single-quoted form with
3274						# escaped apostrophes if no delimiter is
3275						# available.
3276						#
3277						# Entry: $s - the string to wrap. May be undef.
3278						# Exit: Returns a Perl source-code fragment that
3279						# evaluates to the original string value,
3280						# or the string 'undef' if $s is undef.
3281						#
3282						# Notes: index() returns -1 when not found and
3283						# any value >= 0 when found, including 0
3284						# for a delimiter at the start of the
3285						# string. We compare against $INDEX_NOT_FOUND
3286						# to make this boundary explicit and to
3287						# prevent off-by-one mutation survivors.
3288						# See GitHub issue #1.
3289						# --------------------------------------------------
3290						sub q_wrap {
3291	123			123	20352	my $s = $_[0];
3292
3293	123	50			114	croak('q_wrap: argument must be a plain string, not a reference') if ref($s);
3294
3295						# Return empty string for undef â€” this function is a low-level
3296						# string quoter only. Callers that need the Perl literal 'undef'
3297						# for undefined values should use perl_quote() instead, which
3298						# handles the undef -> 'undef' semantic conversion correctly.
3299						# Returning '' here preserves the original behaviour and avoids
3300						# injecting the bare word 'undef' into contexts that expect a
3301						# quoted string value.
3302	123	100			104	return "''" unless defined $s;
3303
3304						# Try bracket-form q{} delimiters first â€” most readable
3305	120				218	for my $p (@Q_BRACKET_PAIRS) {
3306	137 137				307 177	my ($l, $r) = @{$p};
3307
3308						# Only use this bracket pair if neither bracket
3309						# appears in the string â€” both must be checked
3310	137	100			1712	return "q$l$s$r" unless $s =~ /\Q$l\E\|\Q$r\E/;
3311						}
3312
3313						# Try single-character delimiters in preference order
3314	4				16	for my $d (@Q_SINGLE_DELIMITERS) {
3315						# index() returns $INDEX_NOT_FOUND (-1) when not found.
3316						# Must use != $INDEX_NOT_FOUND rather than > 0 since
3317						# the delimiter may legitimately appear at position 0
3318	26	100			148	return "q$d$s$d" if index($s, $d) == $INDEX_NOT_FOUND;
3319						}
3320
3321						# Last resort â€” single-quoted string with escaped apostrophes
3322	2				12	(my $esc = $s) =~ s/'/\\'/g;
3323	2				5	return "'$esc'";
3324						}
3325
3326						# --------------------------------------------------
3327						# perl_sq
3328						#
3329						# Purpose: Escape a string for safe inclusion
3330						# inside a single-quoted Perl string
3331						# literal in generated test code.
3332						#
3333						# Entry: $s - the string to escape.
3334						# Exit: Returns the escaped string, or an
3335						# empty string if $s is undef.
3336						#
3337						# Notes: NUL byte replacement produces the
3338						# two-character sequence \0 which is
3339						# only correct when the result is used
3340						# inside a double-quoted string context
3341						# in the generated test.
3342						#
3343						# The \b substitution (backspace) is
3344						# intentionally omitted â€” in Perl regex
3345						# context \b means word boundary, not
3346						# backspace, so substituting it here
3347						# would corrupt strings containing word
3348						# boundaries.
3349						# --------------------------------------------------
3350						sub perl_sq {
3351	398			398	219190	my $s = $_[0];
3352
3353	398	50			306	croak('perl_sq: argument must be a plain string, not a reference') if ref($s);
3354
3355						# Return empty string for undef â€” callers that need
3356						# 'undef' literal should use perl_quote instead
3357	398	100			326	return '' unless defined $s;
3358
3359						# Escape backslashes first so later substitutions
3360						# don't double-escape already-escaped sequences
3361	396				321	$s =~ s/\\/\\\\/g;
3362
3363						# Escape apostrophes so they don't terminate the
3364						# surrounding single-quoted string literal
3365	396				279	$s =~ s/'/\\'/g;
3366
3367						# Escape common control characters to their
3368						# printable two-character escape sequences
3369	396				268	$s =~ s/\n/\\n/g;
3370	396				289	$s =~ s/\r/\\r/g;
3371	396				248	$s =~ s/\t/\\t/g;
3372	396				281	$s =~ s/\f/\\f/g;
3373
3374						# Replace NUL bytes with \0 â€” valid only in
3375						# double-quoted string context in generated code
3376	396				253	$s =~ s/\0/\\0/g;
3377
3378	396				788	return $s;
3379						}
3380
3381 - 3411						=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
3412
3413						sub perl_quote {
3414	500			500	269024	my ($v) = @_;
3415	500				473	return _perl_quote($v, 0);
3416						}
3417
3418						sub _perl_quote {
3419	625			625	455	my ($v, $depth) = @_;
3420	22 22 22			22	52430 20 47986	no warnings 'recursion'; ## no critic (TestingAndDebugging::ProhibitNoWarnings)
3421	625	100			545	croak('perl_quote: structure too deeply nested (circular reference?)') if $depth > 100;
3422
3423						# Undef produces the Perl literal 'undef'
3424	624	100			467	return 'undef' unless defined $v;
3425
3426						# Convert YAML boolean string literals to Perl
3427						# boolean constants so they survive round-tripping
3428	619	100			512	return '!!1' if $v eq 'true';
3429	616	100			501	return '!!0' if $v eq 'false';
3430
3431	613	100			436	if(ref($v)) {
3432						# Recursively quote each element of an arrayref
3433	141	100			138	if(ref($v) eq 'ARRAY') {
3434	111 125 111				71 140 76	my @quoted_v = map { _perl_quote($_, $depth + 1) } @{$v};
3435	10				24	return '[ ' . join(', ', @quoted_v) . ' ]';
3436						}
3437
3438						# Render Regexp objects as qr{} with modifiers
3439	30	100			44	if(ref($v) eq 'Regexp') {
3440	12				26	my ($pat, $mods) = regexp_pattern($v);
3441	12				76	my $re = "qr{$pat}";
3442
3443						# Append modifiers (e.g. 'i', 'x') if present
3444	12	100			18	$re .= $mods if $mods;
3445	12				26	return $re;
3446						}
3447
3448						# Hashrefs and other reference types fall through
3449						# to render_fallback which uses Data::Dumper
3450	18				31	return render_fallback($v);
3451						}
3452
3453						# Numeric values are emitted unquoted so the generated
3454						# test performs numeric rather than string comparison
3455	472	100			770	return looks_like_number($v) ? $v : "'" . perl_sq($v) . "'";
3456						}
3457
3458						# --------------------------------------------------
3459						# _generate_transform_properties
3460						#
3461						# Convert a hashref of transform
3462						# specifications into an arrayref of
3463						# LectroTest property definition hashrefs,
3464						# one per transform. Each hashref contains
3465						# all the information needed by
3466						# _render_properties to emit a runnable
3467						# Test::LectroTest property block.
3468						#
3469						# Entry: $transforms - hashref of transform name
3470						# => transform spec, as
3471						# loaded from the schema.
3472						# $function - name of the function under
3473						# test.
3474						# $module - module name, or undef for
3475						# builtin functions.
3476						# $input - the top-level input spec
3477						# hashref from the schema
3478						# (used for position sorting).
3479						# $config - the normalised config
3480						# hashref, used to read
3481						# properties.trials.
3482						# $new - defined if the function is
3483						# an object method; the value
3484						# is not used here since
3485						# property tests always
3486						# construct a fresh object
3487						# via new_ok() with no args.
3488						# Presence vs absence is the
3489						# only signal used.
3490						#
3491						# Exit: Returns an arrayref of property hashrefs.
3492						# Returns an empty arrayref if no transforms
3493						# produce any testable properties.
3494						# Never returns undef.
3495						#
3496						# Notes: Transforms whose input is the string
3497						# 'undef' or whose input spec is not a
3498						# hashref are silently skipped â€” they
3499						# represent error-case transforms that have
3500						# no meaningful generator.
3501						#
3502						# The 'WARN' vs 'WARNS' distinction in
3503						# _STATUS: the schema convention uses
3504						# 'WARNS' throughout. This function checks
3505						# for 'WARNS' to match that convention.
3506						# --------------------------------------------------
3507						sub _generate_transform_properties {
3508	11			11	10251	my ($transforms, $function, $module, $input, $config, $new) = @_;
3509
3510	11				9	my @properties;
3511
3512	11 11				6 19	for my $transform_name (sort keys %{$transforms}) {
3513						# $transform_name is spliced by _render_properties as a Perl
3514						# variable name (my $$transform_name = Property {...}), not
3515						# just inside a string literal â€” reject anything that isn't
3516						# identifier-shaped before it reaches that point.
3517	13				16	_assert_identifier($transform_name, 'transform name');
3518
3519	12				11	my $transform = $transforms->{$transform_name};
3520
3521	12				9	my $input_spec = $transform->{input};
3522
3523						# Guard: skip transforms with no input or with the
3524						# YAML scalar 'undef' as their input â€” these have no
3525						# generator and cannot produce meaningful properties
3526	12	100	75		23	if(!defined($input_spec) \|\|
3527						(!ref($input_spec) && $input_spec eq 'undef')) {
3528	2				3	next;
3529						}
3530
3531						# Guard: skip transforms whose input is not a hashref â€”
3532						# must come before the helper calls below so we never
3533						# pass a non-hash to _detect_transform_properties or
3534						# _process_custom_properties
3535	10	100			11	next unless ref($input_spec) eq 'HASH';
3536
3537						# Default output spec to empty hash so _STATUS lookups
3538						# below are always safe regardless of schema content
3539	9		50		17	my $output_spec = $transform->{output} // {};
3540
3541						# Detect automatic properties from the transform spec
3542						# (range constraints, type preservation, definedness)
3543	9				14	my @detected_props = _detect_transform_properties(
3544						$transform_name,
3545						$input_spec,
3546						$output_spec
3547						);
3548
3549						# Process any custom properties defined in the schema
3550	9				10	my @custom_props = ();
3551	9	50	33		12	if(exists($transform->{properties}) &&
3552						ref($transform->{properties}) eq 'ARRAY') {
3553						@custom_props = _process_custom_properties(
3554						$transform->{properties},
3555	0				0	$function,
3556						$module,
3557						$input_spec,
3558						$output_spec,
3559						$new
3560						);
3561						}
3562
3563						# Combine auto-detected and custom properties into one list
3564	9				10	my @all_props = (@detected_props, @custom_props);
3565
3566						# Skip this transform if no properties were produced â€”
3567						# nothing useful to render into the generated test
3568	9	50			8	next unless @all_props;
3569
3570						# Build the LectroTest generator specification string,
3571						# one entry per input field that has a generator
3572	9				9	my @generators;
3573						my @var_names;
3574
3575	9 9				5 10	for my $field (sort keys %{$input_spec}) {
3576	9				11	my $spec = $input_spec->{$field};
3577
3578						# Skip non-hashref field specs â€” scalar types
3579						# like 'string' have no generator sub-structure
3580	9	50			10	next unless ref($spec) eq 'HASH';
3581
3582						# $field is spliced unescaped into the generated
3583						# LectroTest generator spec by
3584						# _schema_to_lectrotest_generator() â€” reject anything
3585						# that isn't identifier-shaped first.
3586	9				11	_assert_identifier($field, 'input field name');
3587
3588	9				11	my $gen = _schema_to_lectrotest_generator($field, $spec);
3589	9	50	33		38	if(defined($gen) && length($gen)) {
3590	9				5	push @generators, $gen;
3591	9				10	push @var_names, $field;
3592						}
3593						}
3594
3595	9				11	my $gen_spec = join(', ', @generators);
3596
3597						# Build the call expression for the function under test.
3598						# Note: property tests always construct a fresh object
3599						# via new_ok() with no constructor arguments, regardless
3600						# of what $new holds in the caller â€” the intent here is
3601						# to test the method in isolation, not with specific
3602						# construction state.
3603	9				8	my $call_code;
3604	9	100 50	33 67		20	if($module && defined($new)) {
3605						# OO mode â€” construct a fresh object for each trial
3606	1				1	$call_code = "my \$obj = new_ok('$module');";
3607	1				2	$call_code .= "\$obj->$function";
3608						} elsif($module && $module ne $MODULE_BUILTIN) {
3609						# Functional mode with a named module
3610	0				0	$call_code = "$module\::$function";
3611						} else {
3612						# Builtin or unqualified function call
3613	8				5	$call_code = $function;
3614						}
3615
3616						# Build the argument list, respecting positional order
3617						# if the input spec declares positions
3618	9				5	my @args;
3619	9	50			15	if(_has_positions($input_spec)) {
3620						# Sort fields by declared position so the generated
3621						# call passes arguments in the correct order
3622						my @sorted = sort {
3623						$input_spec->{$a}{position} <=>
3624						$input_spec->{$b}{position}
3625	9 0 9				7 0 12	} keys %{$input_spec};
3626	9 9				11 14	@args = map { "\$$_" } @sorted;
3627						} else {
3628						# No positions â€” use alphabetical order from @var_names
3629	0 0				0 0	@args = map { "\$$_" } @var_names;
3630						}
3631
3632	9				10	my $args_str = join(', ', @args);
3633
3634						# Concatenate all property check expressions with &&
3635						# so the generated property block passes only when
3636						# every check holds
3637	9 29				7 27	my @checks = map { $_->{code} } @all_props;
3638	9				12	my $property_checks = join(" &&\n\t", @checks);
3639
3640						# Determine expected behaviour from output _STATUS.
3641						# Note: the schema convention uses 'WARNS' not 'WARN'
3642	9		100		19	my $should_die = ($output_spec->{'_STATUS'} // '') eq 'DIES';
3643	9		100		14	my $should_warn = ($output_spec->{'_STATUS'} // '') eq 'WARNS';
3644
3645						push @properties, {
3646						name => $transform_name,
3647						generator_spec => $gen_spec,
3648						call_code => "$call_code($args_str)",
3649						property_checks => $property_checks,
3650						should_die => $should_die,
3651						should_warn => $should_warn,
3652	9		33		62	trials => $config->{'properties'}{'trials'} // $DEFAULT_PROPERTY_TRIALS,
3653						};
3654						}
3655
3656	10				18	return \@properties;
3657						}
3658
3659						# --------------------------------------------------
3660						# _get_semantic_generators
3661						#
3662						# Return a hashref of named semantic
3663						# generator definitions for use in
3664						# LectroTest property-based tests.
3665						# Each entry contains a 'code' key
3666						# holding a Gen {} block string and a
3667						# 'description' key for documentation
3668						# and validation messages.
3669						#
3670						# Entry: None.
3671						#
3672						# Exit: Returns a hashref keyed by semantic
3673						# type name. Each value is a hashref
3674						# with 'code' and 'description' keys.
3675						#
3676						# Notes: The returned hashref is built fresh
3677						# on every call â€” callers that need it
3678						# repeatedly should cache the result.
3679						# The 'code' strings are multi-line
3680						# Gen {} blocks; callers are responsible
3681						# for compressing whitespace before
3682						# embedding them in generated test files.
3683						# --------------------------------------------------
3684						sub _get_semantic_generators {
3685						return {
3686	105			105	7178	email => {
3687						code => q{
3688						Gen {
3689						my $len = 5 + int(rand(10));
3690						my @addr;
3691						my @tlds = qw(com org net edu gov io co uk de fr);
3692
3693						for(my $i = 0; $i < $len; $i++) {
3694						push @addr, pack('c', (int(rand 26))+97);
3695						}
3696						push @addr, '@';
3697						$len = 5 + int(rand(10));
3698						for(my $i = 0; $i < $len; $i++) {
3699						push @addr, pack('c', (int(rand 26))+97);
3700						}
3701						push @addr, '.';
3702						$len = rand($#tlds+1);
3703						push @addr, $tlds[$len];
3704						return join('', @addr);
3705						}
3706						},
3707						description => 'Valid email addresses',
3708						}, url => {
3709						code => q{
3710						Gen {
3711						my @schemes = qw(http https);
3712						my @tlds = qw(com org net io);
3713						my $scheme = $schemes[int(rand(@schemes))];
3714						my $domain = join('', map { ('a'..'z')[int(rand(26))] } 1..(5 + int(rand(10))));
3715						my $tld = $tlds[int(rand(@tlds))];
3716						my $path = join('', map { ('a'..'z', '0'..'9', '-', '_')[int(rand(38))] } 1..int(rand(20)));
3717
3718						return "$scheme://$domain.$tld" . ($path ? "/$path" : '');
3719						}
3720						},
3721						description => 'Valid HTTP/HTTPS URLs',
3722						}, uuid => {
3723						code => q{
3724						Gen {
3725						require UUID::Tiny;
3726						UUID::Tiny::create_uuid_as_string(UUID::Tiny::UUID_V4());
3727						}
3728						},
3729						description => 'Valid UUIDv4 identifiers',
3730						}, phone_us => {
3731						code => q{
3732						Gen {
3733						my $area = 200 + int(rand(800));
3734						my $exchange = 200 + int(rand(800));
3735						my $subscriber = int(rand(10000));
3736						sprintf('%03d-%03d-%04d', $area, $exchange, $subscriber);
3737						}
3738						},
3739						description => 'US phone numbers (XXX-XXX-XXXX format)',
3740						}, phone_e164 => {
3741						code => q{
3742						Gen {
3743						my $country = 1 + int(rand(999));
3744						my $area = 100 + int(rand(900));
3745						my $number = int(rand(10000000));
3746						sprintf('+%d%03d%07d', $country, $area, $number);
3747						}
3748						},
3749						description => 'E.164 international phone numbers',
3750						}, ipv4 => {
3751						code => q{
3752						Gen {
3753						join('.', map { int(rand(256)) } 1..4);
3754						}
3755						},
3756						description => 'IPv4 addresses',
3757						}, ipv6 => {
3758						code => q{
3759						Gen {
3760						join(':', map { sprintf('%04x', int(rand(0x10000))) } 1..8);
3761						}
3762						},
3763						description => 'IPv6 addresses',
3764						}, username => {
3765						code => q{
3766						Gen {
3767						my $len = 3 + int(rand(13));
3768						my @chars = ('a'..'z', '0'..'9', '_', '-');
3769						my $first = ('a'..'z')[int(rand(26))];
3770						$first . join('', map { $chars[int(rand(@chars))] } 1..($len-1));
3771						}
3772						},
3773						description => 'Valid usernames (alphanumeric with _ and -)',
3774						}, slug => {
3775						code => q{
3776						Gen {
3777						my @words = qw(quick brown fox jumps over lazy dog hello world test data);
3778						my $count = 1 + int(rand(4));
3779						join('-', map { $words[int(rand(@words))] } 1..$count);
3780						}
3781						},
3782						description => 'URL slugs (lowercase words separated by hyphens)',
3783						}, hex_color => {
3784						code => q{
3785						Gen {
3786						sprintf('#%06x', int(rand(0x1000000)));
3787						}
3788						},
3789						description => 'Hex color codes (#RRGGBB)',
3790						}, iso_date => {
3791						code => q{
3792						Gen {
3793						my $year = 2000 + int(rand(25));
3794						my $month = 1 + int(rand(12));
3795						my $day = 1 + int(rand(28));
3796						sprintf('%04d-%02d-%02d', $year, $month, $day);
3797						}
3798						},
3799						description => 'ISO 8601 date format (YYYY-MM-DD)',
3800						},
3801						iso_datetime => {
3802						code => q{
3803						Gen {
3804						my $year = 2000 + int(rand(25));
3805						my $month = 1 + int(rand(12));
3806						my $day = 1 + int(rand(28));
3807						my $hour = int(rand(24));
3808						my $minute = int(rand(60));
3809						my $second = int(rand(60));
3810						sprintf('%04d-%02d-%02dT%02d:%02d:%02dZ',
3811						$year, $month, $day, $hour, $minute, $second);
3812						}
3813						},
3814						description => 'ISO 8601 datetime format (YYYY-MM-DDTHH:MM:SSZ)',
3815						}, semver => {
3816						code => q{
3817						Gen {
3818						my $major = int(rand(10));
3819						my $minor = int(rand(20));
3820						my $patch = int(rand(50));
3821						"$major.$minor.$patch";
3822						}
3823						},
3824						description => 'Semantic version strings (major.minor.patch)',
3825						}, jwt => {
3826						code => q{
3827						Gen {
3828						my @chars = ('A'..'Z', 'a'..'z', '0'..'9', '-', '_');
3829						my $header = join('', map { $chars[int(rand(@chars))] } 1..20);
3830						my $payload = join('', map { $chars[int(rand(@chars))] } 1..40);
3831						my $signature = join('', map { $chars[int(rand(@chars))] } 1..30);
3832						"$header.$payload.$signature";
3833						}
3834						},
3835						description => 'JWT-like tokens (base64url format)',
3836						}, json => {
3837						code => q{
3838						Gen {
3839						my @keys = qw(id name value status count);
3840						my $key = $keys[int(rand(@keys))];
3841						my $value = 1 + int(rand(1000));
3842						qq({"$key":$value});
3843						}
3844						},
3845						description => 'Simple JSON objects',
3846						}, base64 => {
3847						code => q{
3848						Gen {
3849						my @chars = ('A'..'Z', 'a'..'z', '0'..'9', '+', '/');
3850						my $len = 12 + int(rand(20));
3851						my $str = join('', map { $chars[int(rand(@chars))] } 1..$len);
3852						$str .= '=' x (4 - ($len % 4)) if $len % 4;
3853						$str;
3854						}
3855						},
3856						description => 'Base64-encoded strings',
3857						}, md5 => {
3858						code => q{
3859						Gen {
3860						join('', map { sprintf('%x', int(rand(16))) } 1..32);
3861						}
3862						},
3863						description => 'MD5 hashes (32 hex characters)',
3864						}, sha256 => {
3865						code => q{
3866						Gen {
3867						join('', map { sprintf('%x', int(rand(16))) } 1..64);
3868						}
3869						},
3870						description => 'SHA-256 hashes (64 hex characters)',
3871						}, unix_timestamp => {
3872						code => q{
3873						Gen {
3874						time;
3875						}
3876						},
3877						description => 'Unix timestamps (seconds since epoch)',
3878						},
3879						};
3880						}
3881
3882						# --------------------------------------------------
3883						# _get_builtin_properties
3884						#
3885						# Purpose: Return a hashref of named built-in
3886						# property templates that can be
3887						# referenced by name in a transform's
3888						# 'properties' list in the schema.
3889						# Each entry contains a 'description'
3890						# string, a 'code_template' coderef, and
3891						# an 'applicable_to' arrayref.
3892						#
3893						# Entry: None.
3894						#
3895						# Exit: Returns a hashref keyed by property
3896						# name. Each value is a hashref with
3897						# 'description', 'code_template', and
3898						# 'applicable_to' keys.
3899						#
3900						# Notes: 'applicable_to' lists the types for
3901						# which each property is meaningful. It
3902						# is stored for documentation purposes
3903						# and potential future filtering â€” it is
3904						# not currently enforced by any caller.
3905						#
3906						# Each 'code_template' coderef receives
3907						# three arguments: ($function, $call_code,
3908						# $input_vars). Most templates use only
3909						# $call_code; $function and $input_vars
3910						# are provided for templates that need
3911						# them (e.g. idempotent, length_preserved,
3912						# preserves_keys).
3913						#
3914						# 'monotonic_increasing' has been
3915						# intentionally omitted. A correct
3916						# implementation requires calling the
3917						# function twice with ordered inputs,
3918						# which the current single-call property
3919						# framework does not support. A
3920						# placeholder that unconditionally returns
3921						# true would give false confidence and has
3922						# therefore been removed.
3923						# --------------------------------------------------
3924						sub _get_builtin_properties {
3925						return {
3926						idempotent => {
3927						description => 'Function is idempotent: f(f(x)) == f(x)',
3928						code_template => sub {
3929	2			2	13579	my ($function, $call_code, $input_vars) = @_;
3930
3931						# String comparison works for all scalar types in Perl â€”
3932						# numeric values stringify consistently for eq
3933	2				3	return "do { my \$tmp = $call_code; \$result eq \$tmp }";
3934						},
3935						applicable_to => ['all'],
3936						}, non_negative => {
3937						description => 'Result is always non-negative',
3938						code_template => sub {
3939	3			3	264	my ($function, $call_code, $input_vars) = @_;
3940	3				3	return '$result >= 0';
3941						},
3942						applicable_to => ['number', 'integer', 'float'],
3943						}, positive => {
3944						description => 'Result is always positive (> 0)',
3945						code_template => sub {
3946	2			2	285	my ($function, $call_code, $input_vars) = @_;
3947	2				2	return '$result > 0';
3948						},
3949						applicable_to => ['number', 'integer', 'float'],
3950						}, non_empty => {
3951						description => 'Result is never empty',
3952						code_template => sub {
3953	2			2	264	my ($function, $call_code, $input_vars) = @_;
3954	2				2	return 'length($result) > 0';
3955						},
3956						applicable_to => ['string'],
3957						},
3958
3959						length_preserved => {
3960						description => 'Output length equals input length',
3961						code_template => sub {
3962	2			2	271	my ($function, $call_code, $input_vars) = @_;
3963	2				2	my $first_var = $input_vars->[0];
3964	2				2	return "length(\$result) == length(\$$first_var)";
3965						},
3966						applicable_to => ['string'],
3967						},
3968
3969						uppercase => {
3970						description => 'Result is all uppercase',
3971						code_template => sub {
3972	2			2	289	my ($function, $call_code, $input_vars) = @_;
3973	2				3	return '$result eq uc($result)';
3974						},
3975						applicable_to => ['string'],
3976						},
3977
3978						lowercase => {
3979						description => 'Result is all lowercase',
3980						code_template => sub {
3981	2			2	278	my ($function, $call_code, $input_vars) = @_;
3982	2				3	return '$result eq lc($result)';
3983						},
3984						applicable_to => ['string'],
3985						},
3986
3987						trimmed => {
3988						description => 'Result has no leading or trailing whitespace',
3989						code_template => sub {
3990	2			2	271	my ($function, $call_code, $input_vars) = @_;
3991	2				4	return '$result !~ /^\s/ && $result !~ /\s$/';
3992						},
3993						applicable_to => ['string'],
3994						},
3995
3996						sorted_ascending => {
3997						description => 'Array is sorted in ascending order',
3998						code_template => sub {
3999	2			2	264	my ($function, $call_code, $input_vars) = @_;
4000	2				2	return 'do { my @arr = @$result; my $sorted = 1; ' .
4001						'for my $i (1..$#arr) { $sorted = 0 if $arr[$i] < $arr[$i-1]; } ' .
4002						'$sorted }';
4003						},
4004						applicable_to => ['arrayref'],
4005						},
4006
4007						sorted_descending => {
4008						description => 'Array is sorted in descending order',
4009						code_template => sub {
4010	2			2	139	my ($function, $call_code, $input_vars) = @_;
4011	2				2	return 'do { my @arr = @$result; my $sorted = 1; ' .
4012						'for my $i (1..$#arr) { $sorted = 0 if $arr[$i] > $arr[$i-1]; } ' .
4013						'$sorted }';
4014						},
4015						applicable_to => ['arrayref'],
4016						},
4017
4018						unique_elements => {
4019						description => 'Array has no duplicate elements',
4020						code_template => sub {
4021	2			2	265	my ($function, $call_code, $input_vars) = @_;
4022	2				3	return 'do { my @arr = @$result; my %seen; !grep { $seen{$_}++ } @arr }';
4023						},
4024						applicable_to => ['arrayref'],
4025						},
4026
4027						preserves_keys => {
4028						description => 'Hash has same keys as input',
4029						code_template => sub {
4030	2			2	266	my ($function, $call_code, $input_vars) = @_;
4031	2				3	my $first_var = $input_vars->[0];
4032	2				2	return 'do { my @in = sort keys %{$' . $first_var . '}; ' .
4033						'my @out = sort keys %$result; ' .
4034						'join(",", @in) eq join(",", @out) }';
4035						},
4036	28			28	32810	applicable_to => ['hashref'],
4037						},
4038						};
4039						}
4040
4041						# --------------------------------------------------
4042						# _schema_to_lectrotest_generator
4043						#
4044						# Purpose: Convert a single schema field spec
4045						# hashref into a LectroTest generator
4046						# declaration string of the form
4047						# '$field <- Generator(...)'.
4048						# Used to build the ##[ ... ]## generator
4049						# block inside a Property definition.
4050						#
4051						# Entry: $field_name - the parameter name as it
4052						# will appear in the
4053						# generated test code.
4054						# $spec - hashref containing at
4055						# minimum a 'type' key.
4056						# May also contain 'min',
4057						# 'max', 'semantic', and
4058						# 'matches' keys depending
4059						# on type.
4060						#
4061						# Exit: Returns a string of the form
4062						# '$field <- Generator(...)' on success.
4063						# Returns undef if the spec is not a
4064						# hashref or if range constraints are
4065						# invalid (min >= max for numeric types).
4066						# Returns a String generator with a carp
4067						# warning for unknown types.
4068						#
4069						# Side effects: Carps on unknown semantic types,
4070						# invalid numeric ranges, and unknown
4071						# field types.
4072						#
4073						# Notes: Semantic generators are checked first
4074						# for string fields and take precedence
4075						# over the regular string generator.
4076						# The $input_spec parameter in the type-
4077						# detection helpers is reserved for future
4078						# use and is currently unused.
4079						# --------------------------------------------------
4080						sub _schema_to_lectrotest_generator {
4081	53			53	39697	my ($field_name, $spec) = @_;
4082
4083						# Guard: must be a hashref to dereference safely
4084	53	100	100		132	return unless defined($spec) && ref($spec) eq 'HASH';
4085
4086						# Default to string when no type is declared
4087	50		33		64	my $type = $spec->{'type'} \|\| $DEFAULT_FIELD_TYPE;
4088
4089						# --------------------------------------------------
4090						# Semantic generators take precedence for string
4091						# fields â€” they produce realistic domain-specific
4092						# values rather than random character sequences
4093						# --------------------------------------------------
4094	50	100	100		80	if($type eq 'string' && defined($spec->{'semantic'})) {
4095	1				1	my $semantic_type = $spec->{'semantic'};
4096	1				2	my $generators = _get_semantic_generators();
4097
4098	1	50			2	if(exists($generators->{$semantic_type})) {
4099	1				1	my $gen_code = $generators->{$semantic_type}{'code'};
4100
4101						# Compress the multi-line generator code into a
4102						# single line for embedding in the ##[ ]## block
4103	1				3	$gen_code =~ s/^\s+//;
4104	1				8	$gen_code =~ s/\s+$//;
4105	1				5	$gen_code =~ s/\n\s+/ /g;
4106
4107	1				5	return "$field_name <- $gen_code";
4108						} else {
4109	0				0	carp "Unknown semantic type '$semantic_type', " .
4110						"falling back to regular string generator";
4111						# Fall through to regular string generation below
4112						}
4113						}
4114
4115						# --------------------------------------------------
4116						# Integer generator
4117						# --------------------------------------------------
4118	49	100			50	if($type eq 'integer') {
4119	10				10	my $min = $spec->{'min'};
4120	10				9	my $max = $spec->{'max'};
4121
4122	10	100 100 100	100		47	if(!defined($min) && !defined($max)) {
4123						# Unconstrained â€” use LectroTest's built-in Int
4124	4				9	return "$field_name <- Int";
4125						} elsif(!defined($min)) {
4126						# Only max defined â€” generate 0 to max
4127	1				3	return "$field_name <- Int(sized => sub { int(rand($max + 1)) })";
4128						} elsif(!defined($max)) {
4129						# Only min defined â€” generate min to min + range
4130	1				9	return "$field_name <- Int(sized => sub { $min + int(rand($DEFAULT_GENERATOR_RANGE)) })";
4131						} else {
4132						# Both defined â€” generate within [min, max]
4133	4				4	my $range = $max - $min;
4134	4				12	return "$field_name <- Int(sized => sub { $min + int(rand($range + 1)) })";
4135						}
4136						}
4137
4138						# --------------------------------------------------
4139						# Float / number generator
4140						# --------------------------------------------------
4141	39	100	100		82	if($type eq 'number' \|\| $type eq 'float') {
4142	21				20	my $min = $spec->{'min'};
4143	21				19	my $max = $spec->{'max'};
4144
4145	21	100 100 100	100		57	if(!defined($min) && !defined($max)) {
4146						# Unconstrained â€” symmetric range around zero
4147	3				9	return "$field_name <- Float(sized => sub { rand($DEFAULT_GENERATOR_RANGE) - $DEFAULT_GENERATOR_RANGE / 2 })";
4148
4149						} elsif(!defined($min)) {
4150						# Only max defined â€” choose range based on sign of max
4151	7	100 100			13	if($max == $ZERO_BOUNDARY) {
4152						# max=0: negative numbers only
4153	5				23	return "$field_name <- Float(sized => sub { -rand($DEFAULT_GENERATOR_RANGE) })";
4154						} elsif($max > $ZERO_BOUNDARY) {
4155						# Positive max: generate 0 to max
4156	1				6	return "$field_name <- Float(sized => sub { rand($max) })";
4157						} else {
4158						# Negative max: generate from (max - range) to max
4159	1				6	return "$field_name <- Float(sized => sub { ($max - $DEFAULT_GENERATOR_RANGE) + rand($DEFAULT_GENERATOR_RANGE + $max) })";
4160						}
4161
4162						} elsif(!defined($max)) {
4163						# Only min defined â€” choose range based on sign of min
4164	6	100 100			10	if($min == $ZERO_BOUNDARY) {
4165						# min=0: positive numbers only
4166	4				17	return "$field_name <- Float(sized => sub { rand($DEFAULT_GENERATOR_RANGE) })";
4167						} elsif($min > $ZERO_BOUNDARY) {
4168						# Positive min: generate min to min + range
4169	1				7	return "$field_name <- Float(sized => sub { $min + rand($DEFAULT_GENERATOR_RANGE) })";
4170						} else {
4171						# Negative min: generate from min to min + range
4172	1				6	return "$field_name <- Float(sized => sub { $min + rand(-$min + $DEFAULT_GENERATOR_RANGE) })";
4173						}
4174
4175						} else {
4176						# Both min and max defined â€” validate then generate
4177	5				7	my $range = $max - $min;
4178	5	100			10	if($range <= $ZERO_BOUNDARY) {
4179	4				35	carp "Invalid range for '$field_name': min=$min, max=$max";
4180						# Return undef rather than emitting a degenerate
4181						# generator that would silently produce wrong values
4182	4				410	return;
4183						}
4184	1				6	return "$field_name <- Float(sized => sub { $min + rand($range) })";
4185						}
4186						}
4187
4188						# --------------------------------------------------
4189						# String generator
4190						# --------------------------------------------------
4191	18	100			17	if($type eq 'string') {
4192	10		100		19	my $min_len = $spec->{'min'} // 0;
4193	10		67		22	my $max_len = $spec->{'max'} // $DEFAULT_MAX_STRING_LEN;
4194
4195						# If a regex pattern is declared, delegate to
4196						# Data::Random::String::Matches for pattern-aware generation
4197	10	100			38	if(defined($spec->{'matches'})) {
4198	6				13	my $pattern = $spec->{'matches'};
4199
4200						# Compile the pattern safely rather than splicing the raw
4201						# string into qr/$pattern/ â€” the raw form lets a pattern
4202						# containing an unescaped '/' break out of the qr//
4203						# delimiter and inject arbitrary Perl into the generated
4204						# test. regexp_pattern() decomposes the already-compiled
4205						# Regexp object back into pattern text that is guaranteed
4206						# to be a self-contained regex body, safe to re-embed.
4207	6 3	100			12 28	my $compiled = ref($pattern) eq 'Regexp' ? $pattern : eval { qr/$pattern/ };
4208	6	50	33		14	if($@ \|\| !defined($compiled)) {
4209	0				0	carp "Invalid matches pattern '$pattern' for field '$field_name': $@";
4210	0				0	return "$field_name <- String(length => [$min_len, $max_len])";
4211						}
4212	6				15	my ($pat, $mods) = regexp_pattern($compiled);
4213	6		50		12	my $safe_re = "qr{$pat}" . ($mods // '');
4214
4215	6	100 100			12	if(defined($spec->{'max'})) {
4216	1				3	return "$field_name <- Gen { Data::Random::String::Matches->create_random_string({ regex => $safe_re, length => $spec->{'max'} }) }";
4217						} elsif(defined($spec->{'min'})) {
4218	1				3	return "$field_name <- Gen { Data::Random::String::Matches->create_random_string({ regex => $safe_re, length => $spec->{'min'} }) }";
4219						} else {
4220	4				10	return "$field_name <- Gen { Data::Random::String::Matches->create_random_string({ regex => $safe_re }) }";
4221						}
4222						}
4223
4224	4				10	return "$field_name <- String(length => [$min_len, $max_len])";
4225						}
4226
4227						# --------------------------------------------------
4228						# Boolean generator
4229						# --------------------------------------------------
4230	8	100			10	if($type eq 'boolean') {
4231	2				3	return "$field_name <- Bool";
4232						}
4233
4234						# --------------------------------------------------
4235						# Arrayref generator
4236						# --------------------------------------------------
4237	6	100			11	if($type eq 'arrayref') {
4238	2		50		5	my $min_size = $spec->{'min'} // 0;
4239	2		33		8	my $max_size = $spec->{'max'} // $DEFAULT_MAX_COLLECTION_SIZE;
4240	2				10	return "$field_name <- List(Int, length => [$min_size, $max_size])";
4241						}
4242
4243						# --------------------------------------------------
4244						# Hashref generator
4245						# LectroTest has no built-in Hash generator so we
4246						# use Elements over a pre-built list of hashrefs
4247						# --------------------------------------------------
4248	4	100			6	if($type eq 'hashref') {
4249	3		100		9	my $min_keys = $spec->{'min'} // 0;
4250	3		67		9	my $max_keys = $spec->{'max'} // $DEFAULT_MAX_COLLECTION_SIZE;
4251	3				11	return "$field_name <- Elements(map { my \%h; for (1..\$_) { \$h{'key'.\$_} = \$_ }; \\\%h } $min_keys..$max_keys)";
4252						}
4253
4254						# --------------------------------------------------
4255						# Unknown type â€” fall back to String with a warning
4256						# --------------------------------------------------
4257	1				10	carp "Unknown type '$type' for '$field_name' LectroTest generator, using String";
4258	1				243	return "$field_name <- String";
4259						}
4260
4261						# --------------------------------------------------
4262						# _is_numeric_transform
4263						#
4264						# Determine whether a transform's output
4265						# spec declares a numeric type, indicating
4266						# that numeric range properties should be
4267						# generated for it.
4268						#
4269						# Entry: $input_spec - the transform's input
4270						# spec hashref. Currently
4271						# unused; reserved for
4272						# future input-type checks.
4273						# $output_spec - the transform's output
4274						# spec hashref.
4275						#
4276						# Exit: Returns 1 if the output type is one of
4277						# 'number', 'integer', or 'float'.
4278						# Returns 0 otherwise.
4279						# --------------------------------------------------
4280						sub _is_numeric_transform {
4281	37			37	4438	my ($input_spec, $output_spec) = @_;
4282
4283						# $input_spec is currently unused â€” reserved for future
4284						# input-side type checking when detecting mixed transforms
4285	37		100 100		65	my $out_type = ($output_spec // {})->{'type'} // '';
4286
4287	37		100		96	return($out_type eq 'number' \|\| $out_type eq 'integer' \|\| $out_type eq 'float');
4288						}
4289
4290						# --------------------------------------------------
4291						# _is_string_transform
4292						#
4293						# Purpose: Determine whether a transform's output
4294						# spec declares a string type, indicating
4295						# that string length and pattern properties
4296						# should be generated for it.
4297						#
4298						# Entry: $input_spec - the transform's input
4299						# spec hashref. Currently
4300						# unused; reserved for
4301						# future input-type checks.
4302						# $output_spec - the transform's output
4303						# spec hashref.
4304						#
4305						# Exit: Returns 1 if the output type is 'string'.
4306						# Returns 0 otherwise.
4307						# --------------------------------------------------
4308						sub _is_string_transform {
4309	31			31	3495	my ($input_spec, $output_spec) = @_;
4310
4311						# $input_spec is currently unused â€” reserved for future
4312						# input-side type checking when detecting mixed transforms
4313	31		100 100		63	my $out_type = ($output_spec // {})->{'type'} // '';
4314
4315	31				46	return($out_type eq 'string');
4316						}
4317
4318						# --------------------------------------------------
4319						# _same_type
4320						#
4321						# Purpose: Determine whether the dominant type of
4322						# a transform's input and output specs
4323						# match, indicating that type-preservation
4324						# properties are meaningful.
4325						#
4326						# Entry: $input_spec - the transform's input
4327						# spec hashref, or a nested
4328						# multi-field hashref.
4329						# $output_spec - the transform's output
4330						# spec hashref.
4331						#
4332						# Exit: Returns 1 if the dominant input and
4333						# output types are identical strings.
4334						# Returns 0 otherwise.
4335						#
4336						# Notes: Uses _get_dominant_type for both sides.
4337						# For multi-field input specs, dominant
4338						# type is the type of the first field
4339						# encountered â€” this is a simplification.
4340						# TODO: extend to handle mixed-type inputs
4341						# by checking all fields, not just the
4342						# first one found.
4343						# --------------------------------------------------
4344						sub _same_type {
4345	31			31	4702	my ($input_spec, $output_spec) = @_;
4346
4347						# Guard: treat missing specs as untyped â€” two untyped
4348						# specs both default to $DEFAULT_FIELD_TYPE and would
4349						# compare equal, which is intentionally conservative
4350	31		100		42	my $in_type = _get_dominant_type($input_spec // {});
4351	31		100		47	my $out_type = _get_dominant_type($output_spec // {});
4352
4353	31				52	return($in_type eq $out_type);
4354						}
4355
4356						# --------------------------------------------------
4357						# _get_dominant_type
4358						#
4359						# Purpose: Extract the most representative type
4360						# string from a spec hashref. For flat
4361						# output specs this is simply the 'type'
4362						# key. For multi-field input specs it is
4363						# the type of the first sub-field found
4364						# that declares one.
4365						#
4366						# Entry: $spec - a spec hashref. May be a flat
4367						# output spec ({ type => '...' })
4368						# or a multi-field input spec
4369						# ({ field => { type => '...' } }).
4370						# May be undef or empty.
4371						#
4372						# Exit: Returns a type string. Returns
4373						# $DEFAULT_FIELD_TYPE ('string') if no
4374						# type can be determined.
4375						# --------------------------------------------------
4376						sub _get_dominant_type {
4377	93			93	6704	my $spec = $_[0];
4378
4379						# Guard: return default for undef or non-hash input
4380	93	100	67		135	return $DEFAULT_FIELD_TYPE
4381						unless defined($spec) && ref($spec) eq 'HASH';
4382
4383						# Flat spec â€” type declared directly
4384	91	100			93	return $spec->{'type'} if defined($spec->{'type'});
4385
4386						# Multi-field spec â€” return the type of the first
4387						# sub-field that declares one
4388	36 36				24 41	for my $field (keys %{$spec}) {
4389	31	100			34	next unless ref($spec->{$field}) eq 'HASH';
4390						return $spec->{$field}{'type'}
4391	29	100			46	if defined($spec->{$field}{'type'});
4392						}
4393
4394						# No type found anywhere â€” return the safe default
4395	8				14	return $DEFAULT_FIELD_TYPE;
4396						}
4397
4398						# --------------------------------------------------
4399						# _render_properties
4400						#
4401						# Purpose: Render an arrayref of property definition
4402						# hashrefs (as produced by
4403						# _generate_transform_properties) into a
4404						# string of Perl source code suitable for
4405						# embedding in a generated test file.
4406						# The output uses Test::LectroTest::Compat
4407						# to run each property as a holds() check.
4408						#
4409						# Entry: $properties - arrayref of property
4410						# hashrefs, each containing: name,
4411						# generator_spec, call_code,
4412						# property_checks, should_die,
4413						# should_warn, trials.
4414						# May be undef or an empty arrayref.
4415						#
4416						# Exit: Returns a string of Perl source code.
4417						# Returns an empty string if $properties
4418						# is undef, not an arrayref, or empty.
4419						#
4420						# Notes: The generated code uses 4-space
4421						# indentation deliberately â€” this is the
4422						# indentation style of the generated test
4423						# file, not of this module. Tabs are used
4424						# in this module's own source; spaces are
4425						# emitted into generated output for
4426						# readability of the produced test files.
4427						# --------------------------------------------------
4428						sub _render_properties {
4429	12			12	9883	my $properties = $_[0];
4430
4431						# Return empty string for absent or non-array input â€”
4432						# callers treat '' as no property block to emit
4433	12	100	100		35	return '' unless defined($properties) && ref($properties) eq 'ARRAY';
4434	9 9	100			7 14	return '' unless @{$properties};
4435
4436	7				7	my $code = "use_ok('Test::LectroTest::Compat');\n\n";
4437
4438	7 7				7 7	for my $prop (@{$properties}) {
4439						# Emit a labelled Property block for each transform property
4440	10				10	$code .= "# Transform property: $prop->{'name'}\n";
4441	10				13	$code .= "my \$$prop->{'name'} = Property {\n";
4442	10				13	$code .= " ##[ $prop->{'generator_spec'} ]##\n";
4443	10				7	$code .= " \n";
4444	10				11	$code .= " my \$result = eval { $prop->{'call_code'} };\n";
4445
4446	10	100			15	if($prop->{'should_die'}) {
4447						# For transforms that expect death, pass if the
4448						# eval caught an exception
4449	2				3	$code .= " my \$died = defined(\$\@) && \$\@;\n";
4450	2				2	$code .= " \$died;\n";
4451						} else {
4452						# For normal transforms, pass only if no exception
4453						# was thrown and all property checks hold
4454	8				8	$code .= " my \$error = \$\@;\n";
4455	8				6	$code .= " \n";
4456	8				7	$code .= " !\$error && (\n";
4457	8				7	$code .= " $prop->{'property_checks'}\n";
4458	8				7	$code .= " );\n";
4459						}
4460
4461	10				11	$code .= "}, name => '$prop->{'name'}', trials => $prop->{'trials'};\n\n";
4462	10				11	$code .= "holds(\$$prop->{'name'});\n";
4463						}
4464
4465	7				13	return $code;
4466						}
4467
4468						# --------------------------------------------------
4469						# _detect_transform_properties
4470						#
4471						# Purpose: Automatically derive a list of testable
4472						# LectroTest property hashrefs from a
4473						# transform's input and output specs.
4474						# Detects numeric range constraints, exact
4475						# value matches, string length constraints,
4476						# type preservation, and definedness.
4477						#
4478						# Entry: $transform_name - string name of the
4479						# transform, used for
4480						# heuristic matching
4481						# (e.g. 'positive').
4482						# $input_spec - the transform's input
4483						# hashref, or the string
4484						# 'undef'.
4485						# $output_spec - the transform's output
4486						# hashref, or undef if
4487						# absent.
4488						#
4489						# Exit: Returns a list of property hashrefs,
4490						# each containing 'name' and 'code' keys.
4491						# Returns an empty list if no properties
4492						# can be detected or if $input_spec is
4493						# undef or the string 'undef'.
4494						#
4495						# Notes: The 'positive' heuristic checks the
4496						# transform name case-insensitively against
4497						# $TRANSFORM_POSITIVE_PATTERN and adds a
4498						# non-negative constraint if matched.
4499						# This is intentionally a rough heuristic
4500						# rather than a precise semantic check.
4501						# --------------------------------------------------
4502						sub _detect_transform_properties {
4503	28			28	14217	my ($transform_name, $input_spec, $output_spec) = @_;
4504
4505	28				16	my @properties;
4506
4507						# Guard: skip undef input and the YAML scalar 'undef'
4508	28	100			36	return @properties unless defined($input_spec);
4509	26	100	67		56	return @properties if(!ref($input_spec) && $input_spec eq 'undef');
4510
4511						# Default output spec to empty hash so all key lookups
4512						# below are safe regardless of what the schema provides
4513	24		50		25	$output_spec //= {};
4514
4515						# --------------------------------------------------
4516						# Property 1: Output range constraints (numeric)
4517						# --------------------------------------------------
4518	24	100			33	if(_is_numeric_transform($input_spec, $output_spec)) {
4519	15	100			20	if(defined($output_spec->{'min'})) {
4520	11				7	my $min = $output_spec->{'min'};
4521	11				24	push @properties, {
4522						name => 'min_constraint',
4523						code => "defined(\$result) && looks_like_number(\$result) && \$result >= $min",
4524						};
4525						}
4526
4527	15	100			16	if(defined($output_spec->{'max'})) {
4528	2				20	my $max = $output_spec->{'max'};
4529	2				6	push @properties, {
4530						name => 'max_constraint',
4531						code => "defined(\$result) && looks_like_number(\$result) && \$result <= $max",
4532						};
4533						}
4534
4535						# Heuristic: transforms named 'positive' (case-insensitive)
4536						# imply a non-negative result constraint
4537	15	100			33	if($transform_name =~ /$TRANSFORM_POSITIVE_PATTERN/i) {
4538	6				26	push @properties, {
4539						name => 'non_negative',
4540						code => "defined(\$result) && looks_like_number(\$result) && \$result >= 0",
4541						};
4542						}
4543						}
4544
4545						# --------------------------------------------------
4546						# Property 2: Specific value output
4547						# --------------------------------------------------
4548	24	100			76	if(defined($output_spec->{'value'})) {
4549	2				2	my $expected = $output_spec->{'value'};
4550
4551						# Numeric refs use == for comparison; scalars use eq
4552						# via perl_quote to produce the correct quoted literal
4553	2	50			6	push @properties, {
4554						name => 'exact_value',
4555						code => ref($expected)
4556						? "\$result == $expected"
4557						: "\$result eq " . perl_quote($expected),
4558						};
4559						}
4560
4561						# --------------------------------------------------
4562						# Property 3: String length constraints
4563						# --------------------------------------------------
4564	24	100			28	if(_is_string_transform($input_spec, $output_spec)) {
4565	6	100			7	if(defined($output_spec->{'min'})) {
4566	2				4	push @properties, {
4567						name => 'min_length',
4568						code => "length(\$result) >= $output_spec->{'min'}",
4569						};
4570						}
4571
4572	6	50			8	if(defined($output_spec->{'max'})) {
4573	0				0	push @properties, {
4574						name => 'max_length',
4575						code => "length(\$result) <= $output_spec->{'max'}",
4576						};
4577						}
4578
4579	6	50			6	if(defined($output_spec->{'matches'})) {
4580	0				0	my $pattern = $output_spec->{'matches'};
4581
4582						# See the matching comment in _schema_to_lectrotest_generator â€”
4583						# compile first and re-embed via regexp_pattern() rather than
4584						# splicing the raw string into qr/$pattern/, which would let
4585						# an unescaped '/' break out of the delimiter.
4586	0 0	0			0 0	my $compiled = ref($pattern) eq 'Regexp' ? $pattern : eval { qr/$pattern/ };
4587	0	0	0		0	if($@ \|\| !defined($compiled)) {
4588	0				0	carp "Invalid matches pattern '$pattern' for transform '$transform_name': $@";
4589						} else {
4590	0				0	my ($pat, $mods) = regexp_pattern($compiled);
4591	0		0		0	my $safe_re = "qr{$pat}" . ($mods // '');
4592	0				0	push @properties, {
4593						name => 'pattern_match',
4594						code => "\$result =~ $safe_re",
4595						};
4596						}
4597						}
4598						}
4599
4600						# --------------------------------------------------
4601						# Property 4: Type preservation
4602						# --------------------------------------------------
4603	24	100			27	if(_same_type($input_spec, $output_spec)) {
4604	22				23	my $type = _get_dominant_type($output_spec);
4605
4606						# Only emit a numeric_type check for numeric types â€”
4607						# string and other types have no equivalent simple check
4608	22	100	75		41	if($type eq 'number' \|\| $type eq 'integer' \|\| $type eq 'float') {
4609	15				18	push @properties, {
4610						name => 'numeric_type',
4611						code => 'looks_like_number($result)',
4612						};
4613						}
4614						}
4615
4616						# --------------------------------------------------
4617						# Property 5: Definedness
4618						# --------------------------------------------------
4619						# Emit a defined() check for all transforms except those
4620						# whose output type is explicitly 'undef' â€” those are
4621						# expected to return nothing
4622	24	100	100		35	unless(($output_spec->{'type'} // '') eq 'undef') {
4623	22				27	push @properties, {
4624						name => 'defined',
4625						code => 'defined($result)',
4626						};
4627						}
4628
4629	24				31	return @properties;
4630						}
4631
4632						# --------------------------------------------------
4633						# _process_custom_properties
4634						#
4635						# Purpose: Process the 'properties' array from a
4636						# transform definition, resolving each
4637						# entry to either a named builtin property
4638						# (looked up from _get_builtin_properties)
4639						# or a custom property with inline code.
4640						#
4641						# Entry: $properties_spec - arrayref of property
4642						# definitions from the
4643						# schema. Each element
4644						# is either a string
4645						# (builtin name) or a
4646						# hashref with 'name'
4647						# and 'code' fields.
4648						# $function - name of the function
4649						# under test.
4650						# $module - module name, or undef
4651						# for builtins.
4652						# $input_spec - the transform's input
4653						# spec hashref.
4654						# $output_spec - the transform's output
4655						# spec hashref.
4656						# $new - defined if the function
4657						# is an OO method; value
4658						# is not used, only
4659						# presence is checked.
4660						#
4661						# Exit: Returns a list of property hashrefs,
4662						# each containing 'name', 'code', and
4663						# 'description' keys.
4664						# Invalid or unrecognised entries are
4665						# skipped with a carp warning.
4666						#
4667						# Side effects: Carps on unrecognised builtin names,
4668						# missing code fields, and invalid
4669						# property definition types.
4670						#
4671						# Notes: The sixth argument is $new (the OO
4672						# constructor signal), not the full schema
4673						# hashref. It is used only to determine
4674						# whether to emit OO-style call code for
4675						# builtin property templates.
4676						# --------------------------------------------------
4677						sub _process_custom_properties {
4678	7			7	10977	my ($properties_spec, $function, $module, $input_spec, $output_spec, $new) = @_;
4679
4680	7				6	my @properties;
4681	7				7	my $builtin_properties = _get_builtin_properties();
4682
4683	7 7				6 8	for my $prop_def (@{$properties_spec}) {
4684	6				7	my $prop_name;
4685						my $prop_code;
4686	6				0	my $prop_desc;
4687
4688	6	100 100			10	if(!ref($prop_def)) {
4689						# Plain string â€” look up as a named builtin property
4690	2				1	$prop_name = $prop_def;
4691
4692	2	100			4	unless(exists($builtin_properties->{$prop_name})) {
4693	1				5	carp "Unknown built-in property '$prop_name', skipping";
4694	1				91	next;
4695						}
4696
4697	1				2	my $builtin = $builtin_properties->{$prop_name};
4698
4699						# Build the argument list, respecting positional order
4700	1 1				1 1	my @var_names = sort keys %{$input_spec};
4701	1				1	my @args;
4702	1	50			2	if(_has_positions($input_spec)) {
4703	1 0				1 0	my @sorted = sort { $input_spec->{$a}{'position'} <=> $input_spec->{$b}{'position'} } @var_names;
4704	1 1				2 2	@args = map { "\$$_" } @sorted;
4705						} else {
4706	0 0				0 0	@args = map { "\$$_" } @var_names;
4707						}
4708
4709						# Build the call expression for the builtin template.
4710						# $new here is the raw OO signal from the caller â€”
4711						# defined means OO mode, undef means functional
4712	1				0	my $call_code;
4713	1	50 50	33 33		4	if($module && defined($new)) {
4714						# OO mode â€” fresh object per trial
4715	0				0	$call_code = "my \$obj = new_ok('$module');";
4716	0				0	$call_code .= "\$obj->$function";
4717						} elsif($module && $module ne $MODULE_BUILTIN) {
4718						# Functional mode with a named module
4719	0				0	$call_code = "$module\::$function";
4720						} else {
4721						# Builtin or unqualified function call
4722	1				1	$call_code = $function;
4723						}
4724	1				2	$call_code .= '(' . join(', ', @args) . ')';
4725
4726						# Instantiate the builtin's code template with the
4727						# call expression and input variable list
4728	1				2	$prop_code = $builtin->{'code_template'}->($function, $call_code, \@var_names);
4729	1				1	$prop_desc = $builtin->{'description'};
4730
4731						} elsif(ref($prop_def) eq 'HASH') {
4732						# Hashref â€” custom property with inline Perl code
4733	3		100		5	$prop_name = $prop_def->{'name'} \|\| 'custom_property';
4734	3				4	$prop_code = $prop_def->{'code'};
4735	3		67		6	$prop_desc = $prop_def->{'description'} \|\| "Custom property: $prop_name";
4736
4737	3	100			4	unless($prop_code) {
4738	1				5	carp "Custom property '$prop_name' missing 'code' field, skipping";
4739	1				103	next;
4740						}
4741
4742						# Sanity-check: code must contain at least a variable
4743						# reference or a word character to be meaningful
4744	2	50	33		5	unless($prop_code =~ /\$/ \|\| $prop_code =~ /\w+/) {
4745	0				0	carp "Custom property '$prop_name' code looks invalid: $prop_code";
4746	0				0	next;
4747						}
4748
4749						} else {
4750						# Neither string nor hashref â€” unrecognised definition type
4751	1				2	carp 'Invalid property definition: ', render_fallback($prop_def);
4752	1				81	next;
4753						}
4754
4755	3				5	push @properties, {
4756						name => $prop_name,
4757						code => $prop_code,
4758						description => $prop_desc,
4759						};
4760						}
4761
4762	7				72	return @properties;
4763						}
4764
4765 - 4842						=head1 NOTES C<seed> and C<iterations> really should be within C<config>. =head1 SEE ALSO =over 4 =item * L<Test Dashboard\|https://nigelhorne.github.io/App-Test-Generator/coverage/> =item * L<App::Test::Generator::Template> - Template of the file of tests created by C<App::Test::Generator> =item * L<App::Test::Generator::SchemaExtractor> - Create schemas from Perl programs =item * L<Params::Validate::Strict>: Schema Definition =item * L<Params::Get>: Input validation =item * L<Return::Set>: Output validation =item * L<Test::LectroTest> =item * L<Test::Most> =item * L<YAML::XS> =back =head1 AUTHOR Nigel Horne, C<< <njh at nigelhorne.com> >> Portions of this module's initial design and documentation were created with the assistance of AI. =head1 SUPPORT This module is provided as-is without any warranty. You can find documentation for this module with the perldoc command. perldoc App::Test::Generator You can also look for information at: =over 4 =item * MetaCPAN L<https://metacpan.org/release/App-Test-Generator> =item * GitHub L<https://github.com/nigelhorne/App-Test-Generator> =item * CPANTS L<http://cpants.cpanauthors.org/dist/App-Test-Generator> =item * CPAN Testers' Matrix L<http://matrix.cpantesters.org/?dist=App-Test-Generator> =item * CPAN Testers Dependencies L<http://deps.cpantesters.org/?module=App::Test::Generator> =back =head1 LICENCE AND COPYRIGHT Copyright 2025-2026 Nigel Horne. Usage is subject to the terms of GPL2. If you use it, please let me know. =cut
4843
4844						1;