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	1208542 59	use 5.036;
12
13	22 22 22			22	36 16 179	use strict;
14	22 22 22			22	35 16 473	use warnings;
15	22 22 22			22	2466 71601 61	use autodie qw(:all);
16
17	22 22 22			22	116150 2324 41	use utf8;
18	22 22 22			22	3830 10686 58	use open qw(:std :encoding(UTF-8));
19
20	22 22 22			22	122508 30 361	use App::Test::Generator::Template;
21	22 22 22			22	46 20 618	use Carp qw(carp croak confess);
22	22 22 22			22	7867 613310 439	use Config::Abstraction 0.36;
23	22 22 22			22	3150 29381 694	use Data::Dumper;
24	22 22 22			22	50 21 373	use Data::Section::Simple;
25	22 22 22			22	40 21 543	use File::Basename qw(basename);
26	22 22 22			22	35 19 262	use File::Spec;
27	22 22 22			22	5504 176441 751	use Module::Load::Conditional qw(check_install can_load);
28	22 22 22			22	65 19 429	use Params::Get;
29	22 22 22			22	46 203 279	use Params::Validate::Strict 0.36;
30	22 22 22			22	37 19 314	use Readonly;
31	22 22 22			22	40 17 1426	use Readonly::Values::Boolean;
32	22 22 22			22	39 20 451	use Scalar::Util qw(looks_like_number);
33	22 22 22			22	44 43 1579	use re 'regexp_pattern';
34	22 22 22			22	5301 163950 391	use Template;
35	22 22 22			22	3206 22108 591	use YAML::XS qw(LoadFile);
36
37	22 22 22			22	49 27 47737	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 - 1582						=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>. =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
1583
1584 - 1613						=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
1614
1615						sub generate
1616						{
1617	107	50		107	3416071	croak 'Usage: generate(schema_file [, outfile])' if(scalar(@_) == 0);
1618
1619						# Accept both class-method call (App::Test::Generator->generate(...))
1620						# and plain-function call with a hashref (generate({...})).
1621						# In the method form the first arg is the class name (a plain string);
1622						# in the function form with a hashref the first arg IS the hashref.
1623	107	50			294	my $class = (ref($_[0]) ne 'HASH') ? shift : undef;
1624	107				336	my ($schema_file, $test_file, $schema);
1625						# Globals loaded from the user's conf (all optional except function maybe)
1626	107				0	my ($module, $function, $new, $yaml_cases);
1627	107				0	my ($seed, $iterations);
1628
1629	107	100	100		457	if((ref($_[0]) eq 'HASH') \|\| defined($_[2])) {
1630						# Modern API
1631	14				95	my $params = Params::Validate::Strict::validate_strict({
1632						args => Params::Get::get_params(undef, \@_),
1633						schema => {
1634						input_file => { type => 'string', optional => 1 },
1635						schema_file => { type => 'string', optional => 1 },
1636						output_file => { type => 'string', optional => 1 },
1637						schema => { type => 'hashref', optional => 1 },
1638						quiet => { type => 'boolean', optional => 1 }, # Not yet used
1639						}
1640						});
1641	14	100 100 50			3120	if($params->{'schema_file'}) {
1642	5				8	$schema_file = $params->{'schema_file'};
1643						} elsif($params->{'input_file'}) {
1644	1				2	$schema_file = $params->{'input_file'};
1645						} elsif($params->{'schema'}) {
1646	8				16	$schema = $params->{'schema'};
1647						} else {
1648	0				0	croak(__PACKAGE__, ': Usage: generate(input_file\|schema [, output_file]');
1649						}
1650	14	100			34	if(defined($schema_file)) {
1651	6				16	$schema = _load_schema($schema_file);
1652						}
1653	14				121	$test_file = $params->{'output_file'};
1654						} else {
1655						# Legacy API
1656	93				162	($schema_file, $test_file) = @_;
1657	93	100			169	if(defined($schema_file)) {
1658	88				249	$schema = _load_schema($schema_file);
1659						} else {
1660	5				46	croak 'Usage: generate(schema_file [, outfile])';
1661						}
1662						}
1663
1664						# Parse the schema file and load into our structures
1665	99 99				1024 261	my %input = %{_load_schema_section($schema, 'input', $schema_file)};
1666	98 98				132 120	my %output = %{_load_schema_section($schema, 'output', $schema_file)};
1667	97 97				121 123	my %transforms = %{_load_schema_section($schema, 'transforms', $schema_file)};
1668	96 96				131 122	my %accessor = %{_load_schema_section($schema, 'accessor', $schema_file)};
1669
1670	96 2	100			249 3	my %cases = %{$schema->{cases}} if(exists($schema->{cases}));
1671	96 0	50			217 0	my %edge_cases = %{$schema->{edge_cases}} if(exists($schema->{edge_cases}));
1672	96 1	100			172 2	my %type_edge_cases = %{$schema->{type_edge_cases}} if(exists($schema->{type_edge_cases}));
1673
1674	96	100	67		396	$module = $schema->{module} if(exists($schema->{module}) && length($schema->{module}));
1675	96	100			226	$function = $schema->{function} if(exists($schema->{function}));
1676	96	100			194	if(exists($schema->{new})) {
1677	19	100			44	$new = defined($schema->{'new'}) ? $schema->{new} : '_UNDEF';
1678						}
1679	96	100			171	$yaml_cases = $schema->{yaml_cases} if(exists($schema->{yaml_cases}));
1680	96	100			167	$seed = $schema->{seed} if(exists($schema->{seed}));
1681	96	100			171	$iterations = $schema->{iterations} if(exists($schema->{iterations}));
1682
1683	96 3	100			148 8	my @edge_case_array = @{$schema->{edge_case_array}} if(exists($schema->{edge_case_array}));
1684	96				266	_validate_config($schema);
1685
1686	93 10	100			221 40	my %config = %{$schema->{config}} if(exists($schema->{config}));
1687
1688	93				301	_normalize_config(\%config);
1689
1690						# Guess module name from config file if not set
1691	93	100 100			558	if(!$module) {
1692	5	100			8	if($schema_file) {
1693	4				78	($module = basename($schema_file)) =~ s/\.(conf\|pl\|pm\|yml\|yaml)$//;
1694	4				9	$module =~ s/-/::/g;
1695						# Guard against Perl builtin function names being mistaken
1696						# for module names â€” builtins have no module to load
1697	4	100			9	if(_is_perl_builtin($module)) {
1698	1				2	undef $module;
1699						}
1700						}
1701						} elsif($module eq $MODULE_BUILTIN) {
1702	54				171	undef $module;
1703						}
1704
1705	93	50	50		370	if($module && length($module) && ($module ne 'builtin')) {
1706	37				103	_validate_module($module, $schema_file);
1707						}
1708
1709						# $module/$function are spliced unescaped into generated test
1710						# source below (use_ok, new_ok, ->$function, $module::$function)
1711						# â€” reject anything that isn't identifier-shaped before that happens.
1712	93	100	67		303	_assert_identifier($module, 'module', package => 1) if defined($module) && length($module);
1713
1714						# sensible defaults
1715	92		50		125	$function \|\|= 'run';
1716						# package => 1: fully-qualified sub names (e.g. DB::DB, a debugger
1717						# hook installed into the DB:: package regardless of its source
1718						# package) are legitimate function names, not just bare identifiers
1719	92				229	_assert_identifier($function, 'function', package => 1);
1720	90		67		346	$iterations \|\|= $DEFAULT_ITERATIONS; # default fuzz runs if not specified
1721	90	50	67		383	$seed = undef if defined $seed && $seed eq ''; # treat empty as undef
1722
1723						# --- YAML corpus support (yaml_cases is filename string) ---
1724	90				82	my %yaml_corpus_data;
1725	90	100			153	if (defined $yaml_cases) {
1726	5	100			71	croak("$yaml_cases: $!") if(!-f $yaml_cases);
1727
1728	4				23	my $yaml_data = LoadFile(Encode::decode('utf8', $yaml_cases));
1729	4	50	33		322	if ($yaml_data && ref($yaml_data) eq 'HASH') {
1730						# Validate that the corpus inputs are arrayrefs
1731						# e.g: "FooBar": ["foo_bar"]
1732						# Skip only invalid entries:
1733	4 4				4 10	for my $expected (keys %{$yaml_data}) {
1734	6				5	my $outputs = $yaml_data->{$expected};
1735	6	100	67		14	unless($outputs && (ref $outputs eq 'ARRAY')) {
1736	2				15	carp("$yaml_cases: $expected does not point to an array ref, ignoring");
1737	2				201	next;
1738						}
1739	4				6	$yaml_corpus_data{$expected} = $outputs;
1740						}
1741						}
1742						}
1743
1744						# Merge Perl %cases and YAML corpus safely
1745						# my %all_cases = (%cases, %yaml_corpus_data);
1746	89				165	my %all_cases = (%yaml_corpus_data, %cases);
1747	89				175	for my $k (keys %yaml_corpus_data) {
1748	4	50	50		14	if (exists $cases{$k} && ref($cases{$k}) eq 'ARRAY' && ref($yaml_corpus_data{$k}) eq 'ARRAY') {
1749	1 1 1				1 2 2	$all_cases{$k} = [ @{$yaml_corpus_data{$k}}, @{$cases{$k}} ];
1750						}
1751						}
1752
1753	89	100			213	if(my $hints = delete $schema->{_yamltest_hints}) {
1754	8	50			26	if(my $boundaries = $hints->{boundary_values}) {
1755	8 8				9 20	push @edge_case_array, @{$boundaries};
1756						}
1757	8	50			20	if(my $invalid = $hints->{invalid}) {
1758	0				0	carp('TODO: handle yamltest_hints->invalid');
1759						}
1760						}
1761
1762						# If the schema says the type is numeric, normalize
1763	89	100	67		232	if ($schema->{type} && $schema->{type} =~ /^(integer\|number\|float)$/) {
1764	1				3	for (@edge_case_array) {
1765	2	50			3	next unless defined $_;
1766	2	100			9	$_ += 0 if Scalar::Util::looks_like_number($_);
1767						}
1768						}
1769
1770						# Load relationships from the schema if present and well-formed.
1771						# SchemaExtractor may set this to undef or an empty arrayref when
1772						# no relationships were detected, so guard both existence and type.
1773	89				86	my @relationships;
1774	89	50	33		208	if(exists($schema->{relationships}) && ref($schema->{relationships}) eq 'ARRAY') {
1775	0 0				0 0	@relationships = @{$schema->{relationships}};
1776						}
1777
1778						# Serialise the relationships array from the schema into Perl source
1779						# code for embedding in the generated test file. Each relationship
1780						# type is rendered as a hashref in the @relationships array.
1781
1782	89				110	my $relationships_code = '';
1783
1784						# Walk each relationship in the order SchemaExtractor produced them
1785	89				146	for my $rel (@relationships) {
1786	0		0		0	my $type = $rel->{type} // '';
1787
1788						# Mutually exclusive: both params being set should cause the method to die
1789	0	0 0 0 0 0 0			0	if($type eq 'mutually_exclusive') {
1790						$relationships_code .= "{ type => 'mutually_exclusive', params => [" .
1791	0 0 0				0 0 0	join(', ', map { perl_quote($_) } @{$rel->{params}}) .
1792						"] },\n";
1793
1794						# Required group: at least one of the params must be present
1795						} elsif($type eq 'required_group') {
1796						$relationships_code .= "{ type => 'required_group', params => [" .
1797	0 0				0 0	join(', ', map { perl_quote($_) } @{$rel->{params}}) .
1798	0		0		0	"], logic => " . perl_quote($rel->{logic} // 'or') . " },\n";
1799
1800						# Conditional requirement: if one param is set, another becomes mandatory
1801						} elsif($type eq 'conditional_requirement') {
1802						$relationships_code .= "{ type => 'conditional_requirement', if => " .
1803						perl_quote($rel->{'if'}) . ", then_required => " .
1804	0				0	perl_quote($rel->{then_required}) . " },\n";
1805
1806						# Dependency: one param requires another to also be present
1807						} elsif($type eq 'dependency') {
1808						$relationships_code .= "{ type => 'dependency', param => " .
1809						perl_quote($rel->{param}) . ", requires => " .
1810	0				0	perl_quote($rel->{requires}) . " },\n";
1811
1812						# Value constraint: one param being set forces another to a specific value
1813						} elsif($type eq 'value_constraint') {
1814						$relationships_code .= "{ type => 'value_constraint', if => " .
1815						perl_quote($rel->{'if'}) . ", then => " .
1816						perl_quote($rel->{then}) . ", operator => " .
1817						perl_quote($rel->{operator}) . ", value => " .
1818	0				0	perl_quote($rel->{value}) . " },\n";
1819
1820						# Value conditional: one param equalling a specific value requires another param
1821						} elsif($type eq 'value_conditional') {
1822						$relationships_code .= "{ type => 'value_conditional', if => " .
1823						perl_quote($rel->{'if'}) . ", equals => " .
1824						perl_quote($rel->{equals}) . ", then_required => " .
1825	0				0	perl_quote($rel->{then_required}) . " },\n";
1826
1827						# Unknown type â€” warn and skip rather than emitting broken code
1828						} else {
1829	0				0	carp "Unknown relationship type '$type', skipping";
1830						}
1831						}
1832
1833						# Dedup the edge cases
1834	89				88	my %seen;
1835						@edge_case_array = grep {
1836	89 108	100 50			154 205	my $key = defined($_) ? (Scalar::Util::looks_like_number($_) ? "N:$_" : "S:$_") : 'U';
1837	108				237	!$seen{$key}++;
1838						} @edge_case_array;
1839
1840						# Sort the edge cases to keep it consistent across runs
1841						@edge_case_array = sort {
1842	89 148	50			222 144	return -1 if !defined $a;
1843	148	50			133	return 1 if !defined $b;
1844
1845	148				119	my $na = Scalar::Util::looks_like_number($a);
1846	148				121	my $nb = Scalar::Util::looks_like_number($b);
1847
1848	148	100	100		239	return $a <=> $b if $na && $nb;
1849	18	100			18	return -1 if $na;
1850	13	100			15	return 1 if $nb;
1851	11				11	return $a cmp $b;
1852						} @edge_case_array;
1853
1854						# render edge case maps for inclusion in the .t
1855	89				246	my $edge_cases_code = render_arrayref_map(\%edge_cases);
1856	89				131	my $type_edge_cases_code = render_arrayref_map(\%type_edge_cases);
1857
1858	89				106	my $edge_case_array_code = '';
1859	89	100			139	if(scalar(@edge_case_array)) {
1860	22 98				26 107	$edge_case_array_code = join(', ', map { q_wrap($_) } @edge_case_array);
1861						}
1862
1863						# Render configuration - all the values are integers for now, if that changes, wrap the $config{$key} in single quotes
1864	89				127	my $config_code = '';
1865	89				328	foreach my $key (sort keys %config) {
1866						# Skip nested structures like 'properties' - they're used during
1867						# generation but don't need to be in the generated test
1868	712	100			654	if(ref($config{$key}) eq 'HASH') {
1869	89				107	next;
1870						}
1871	623	100	67		745	if((!defined($config{$key})) \|\| !$config{$key}) {
1872						# YAML will strip the word 'false'
1873						# e.g. in 'test_undef: false'
1874	29				27	$config_code .= "'$key' => 0,\n";
1875						} else {
1876	594				476	$config_code .= "'$key' => $config{$key},\n";
1877						}
1878						}
1879
1880						# Render input/output
1881	89				132	my $input_code = '';
1882	89	100	75		354	if(((scalar keys %input) == 1) && exists($input{'type'}) && !ref($input{'type'})) {
1883						# %input = ( type => 'string' );
1884	50				132	foreach my $key (sort keys %input) {
1885	50				83	$input_code .= "'$key' => '$input{$key}',\n";
1886						}
1887						} else {
1888						# %input = ( str => { type => 'string' } );
1889	39				127	$input_code = render_hash(\%input);
1890						}
1891	89	50			191	if(defined(my $re = $output{'matches'})) {
1892	0	0			0	if(ref($re) ne 'Regexp') {
1893						# Use eval to compile safely â€” qr/$re/ would interpolate
1894						# the string first, corrupting patterns containing [ or \
1895	0 0				0 0	my $compiled = eval { qr/$re/ };
1896	0	0			0	if($@) {
1897	0				0	carp("Invalid matches pattern '$re': $@");
1898						} else {
1899	0				0	$output{'matches'} = $compiled;
1900						}
1901						}
1902						}
1903
1904						# Compile nomatch pattern to a Regexp object so it renders
1905						# as qr{} in the generated test rather than a raw string.
1906						# Without this, patterns containing [ or other regex
1907						# metacharacters cause compilation failures in validators
1908	89	50			183	if(defined(my $re = $output{'nomatch'})) {
1909	0	0			0	if(ref($re) ne 'Regexp') {
1910						# Use eval to compile safely â€” qr/$re/ would interpolate
1911						# the string first, corrupting patterns containing [ or \
1912	0 0				0 0	my $compiled = eval { qr/$re/ };
1913	0	0			0	if($@) {
1914	0				0	carp("Invalid nomatch pattern '$re': $@");
1915						} else {
1916	0				0	$output{'nomatch'} = $compiled;
1917						}
1918						}
1919						}
1920
1921	89				193	my $output_code = render_args_hash(\%output);
1922	89	100	100		271	my $new_code = ($new && (ref $new eq 'HASH')) ? render_args_hash($new) : '';
1923
1924	89				94	my $transforms_code;
1925	89	100			182	if(keys %transforms) {
1926	5				8	foreach my $transform(keys %transforms) {
1927	8				19	my $properties = render_fallback($transforms{$transform}->{'properties'});
1928
1929	8	100			20	if($transforms_code) {
1930	3				5	$transforms_code .= "},\n";
1931						}
1932						$transforms_code .= "$transform => {\n" .
1933						"\t'input' => { " .
1934						render_args_hash($transforms{$transform}->{'input'}) .
1935						"\t}, 'output' => { " .
1936	8				16	render_args_hash($transforms{$transform}->{'output'}) .
1937						"\t}, 'properties' => $properties\n" .
1938						"\t,\n";
1939						}
1940	5				6	$transforms_code .= "}\n";
1941						}
1942
1943	89				113	my $transform_properties_code = '';
1944	89				90	my $use_properties = 0;
1945
1946	89	100	67		150	if (keys %transforms && ($config{properties}{enable} // 0)) {
1947	4				4	$use_properties = 1;
1948
1949						# Generate property-based tests for transforms
1950	4				11	my $properties = _generate_transform_properties(
1951						\%transforms,
1952						$function,
1953						$module,
1954						\%input,
1955						\%config,
1956						$new
1957						);
1958
1959						# Convert to code for template
1960	3				4	$transform_properties_code = _render_properties($properties);
1961						}
1962
1963	88	100			137	if(keys %accessor) {
1964						# Sanity test
1965	7				13	my $property = $accessor{property};
1966	7				15	my $type = $accessor{type};
1967
1968	7	50			20	if(!defined($new)) {
1969						# Internal invariant â€” schema has a contradictory accessor+type combination;
1970						# confess gives the full call chain to aid debugging
1971	0				0	confess("invariant violation: $property: accessor $type can only work on an object, incorrectly tagged as $type");
1972						}
1973	7	100			15	if($type eq 'getset') {
1974	4	100			6	if(scalar(keys %input) != 1) {
1975	1				15	confess("invariant violation: $property: getset must take one input argument, incorrectly tagged as getset");
1976						}
1977	3	100			4	if(scalar(keys %output) == 0) {
1978	1				13	confess("invariant violation: $property: getset must give one output, incorrectly tagged as getset");
1979						}
1980						}
1981						}
1982
1983						# Setup / call code (always load module)
1984	86	100			173	my $setup_code = ($module) ? "BEGIN { use_ok('$module') }" : '';
1985	86				101	my $call_code; # Code to call the function being test when used with named arguments
1986						my $position_code; # Code to call the function being test when used with position arguments
1987	86				175	my $has_positions = _has_positions(\%input);
1988	86	100 100	67 100		824	if(defined($new) && defined($module)) {
1989						# keep use_ok regardless (user found earlier issue)
1990	16	100			32	if($new_code eq '') {
1991	15				20	$new_code = "new_ok('$module')";
1992						} else {
1993	1				2	$new_code = "new_ok('$module' => [ { $new_code } ] )";
1994						}
1995	16				20	$setup_code .= "\nmy \$obj = $new_code;";
1996	16	100			23	if($has_positions) {
1997	5				8	$position_code = "\$result = (scalar(\@alist) == 1) ? \$obj->$function(\$alist[0]) : (scalar(\@alist) == 0) ? \$obj->$function() : \$obj->$function(\@alist);";
1998	5	50			10	if(defined($accessor{type})) {
1999	0	0 0			0	if($accessor{type} eq 'getter') {
2000	0				0	$position_code .= "my \$prev_value = \$obj->{$accessor{property}};";
2001						} elsif($accessor{type} eq 'getset') {
2002	0				0	$position_code .= 'if(scalar(@alist) == 1) { ';
2003	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');";
2004	0				0	$position_code .= '}';
2005						}
2006	0	0	0		0	if(($accessor{type} eq 'getset') \|\| ($accessor{type} eq 'getter')) {
2007						# Since Perl doesn't support data encapsulation, we can test the getter returns the correct item
2008	0				0	$position_code .= 'if(scalar(@alist) == 1) { ';
2009	0				0	$position_code .= "cmp_ok(\$result, 'eq', \$obj->{$accessor{property}}, 'getset function returns correct item');";
2010	0	0			0	if($accessor{type} eq 'getter') {
2011	0				0	$position_code .= "if(defined(\$prev_value)) { cmp_ok(\$result, 'eq', \$prev_value, 'getter does not change value'); } ";
2012						}
2013	0				0	$position_code .= '}';
2014						}
2015	0	0			0	if($output{'_returns_self'}) {
2016	0				0	croak("$accessor{type} for $accessor{property} cannot return \$self");
2017						}
2018						}
2019						} else {
2020	11				19	$call_code = "\$result = \$obj->$function(\$input);";
2021	11	50 100	100		52	if($output{'_returns_self'}) {
2022	0				0	$call_code .= "ok(defined(\$result)); ok(\$result eq \$obj, '$function returns self')";
2023						} elsif(defined($accessor{type}) && ($accessor{type} eq 'getset')) {
2024	2				3	$call_code .= "ok(\$obj->$function() eq \$result, 'test getset accessor');"
2025						}
2026	11	100			29	if(scalar(keys %input) == 0) {
2027	6	100	67		27	if(defined($accessor{type}) && ($accessor{type} eq 'getter')) {
2028	3				8	$call_code .= "cmp_ok(\$result, 'eq', \$obj->{$accessor{property}}, 'getter function returns correct item') if(defined(\$result));";
2029						}
2030						}
2031						}
2032						} elsif(defined($module) && length($module)) {
2033	17	100			35	if($function eq 'new') {
2034	2	50			9	if($has_positions) {
2035	0				0	$position_code = "\$result = (scalar(\@alist) == 1) ? ${module}\->$function(\$alist[0]) : (scalar(\@alist) == 0) ? ${module}\->$function() : ${module}\->$function(\@alist);";
2036						} else {
2037	2				9	$call_code = "\$result = ${module}\->$function(\$input);";
2038						}
2039						} else {
2040	15	100			18	if($has_positions) {
2041	1				3	$position_code = "\$result = (scalar(\@alist) == 1) ? ${module}::$function(\$alist[0]) : (scalar(\@alist) == 0) ? ${module}::$function() : ${module}::$function(\@alist);";
2042						} else {
2043	14				24	$call_code = "\$result = ${module}::$function(\$input);";
2044						}
2045						}
2046						} else {
2047	53	100			66	if($has_positions) {
2048	7				14	$position_code = "\$result = $function(\@alist);";
2049						} else {
2050	46				58	$call_code = "\$result = $function(\$input);";
2051						}
2052						}
2053
2054						# List-context capture: $result = func() in scalar context returns a count, not the list.
2055						# When the schema says output type is 'array', capture into @_r then take a ref.
2056	86	100	100		258	if(($output{type} // '') eq 'array') {
2057	2	50			2	if(defined($call_code)) {
2058	2				12	$call_code =~ s/\A\$result = ([^;]+);/my \@_r = ($1); \$result = \\\@_r;/;
2059						}
2060	2	50			3	if(defined($position_code)) {
2061	0				0	$position_code =~ s/\A\$result = ([^;]+);/my \@_r = ($1); \$result = \\\@_r;/;
2062						}
2063						}
2064
2065						# Build static corpus code
2066	86				105	my $corpus_code = '';
2067	86	100			117	if (%all_cases) {
2068	3				6	$corpus_code = "\n# --- Static Corpus Tests ---\n" .
2069						"diag('Running " . scalar(keys %all_cases) . " corpus tests');\n";
2070
2071	3				6	for my $expected (sort keys %all_cases) {
2072	6				6	my $inputs = $all_cases{$expected};
2073	6	50			6	next unless($inputs);
2074
2075	6				6	my $expected_str = perl_quote($expected);
2076	6		33		10	my $status = ((ref($inputs) eq 'HASH') && $inputs->{'_STATUS'}) // 'OK';
2077	6	50 50			12	if($expected_str eq "'_STATUS:DIES'") {
2078	0				0	$status = 'DIES';
2079						} elsif($expected_str eq "'_STATUS:WARNS'") {
2080	0				0	$status = 'WARNS';
2081						}
2082
2083	6	50			8	if(ref($inputs) eq 'HASH') {
2084	0				0	$inputs = $inputs->{'input'};
2085						}
2086	6				5	my $input_str;
2087	6	50 0			8	if(ref($inputs) eq 'ARRAY') {
2088	6 9 6				7 10 4	$input_str = join(', ', map { perl_quote($_) } @{$inputs});
2089						} elsif(ref($inputs) eq 'HASH') {
2090	0				0	$input_str = render_fallback($inputs);
2091
2092						# YAML can't express Perl's undef, so a corpus value of
2093						# the sentinel string 'undef' means "this param is
2094						# undef" -- convert the quoted sentinel back to the
2095						# bareword so the generated test passes real undef
2096	0				0	$input_str =~ s/=> 'undef'/=> undef/gms;
2097						} else {
2098	0				0	$input_str = $inputs;
2099						}
2100	6	50	33		9	if(($input_str eq 'undef') && (!$config{'test_undef'})) {
2101	0				0	carp('corpus case set to undef, yet test_undef is not set in config');
2102						}
2103	6	50			12	if($new) {
2104	0	0 0			0	if($status eq 'DIES') {
2105						$corpus_code .= "dies_ok { \$obj->$function($input_str) } " .
2106	0 0		0		0 0	"'$function(" . join(', ', map { $_ // '' } @$inputs ) . ") dies';\n";
2107						} elsif($status eq 'WARNS') {
2108						$corpus_code .= "warnings_exist { \$obj->$function($input_str) } qr/./, " .
2109	0 0		0		0 0	"'$function(" . join(', ', map { $_ // '' } @$inputs ) . ") warns';\n";
2110						} else {
2111						my $desc = sprintf("$function(%s) returns %s",
2112	0 0		0		0 0	perl_quote(join(', ', map { $_ // '' } @$inputs )),
2113						$expected_str
2114						);
2115	0	0	0		0	if(($output{'type'} // '') eq 'boolean') {
2116	0	0 0			0	if($expected_str eq '1') {
2117	0				0	$corpus_code .= "ok(\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
2118						} elsif($expected_str eq '0') {
2119	0				0	$corpus_code .= "ok(!\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
2120						} else {
2121	0				0	croak("Boolean is expected to return $expected_str");
2122						}
2123						} else {
2124	0				0	$corpus_code .= "is(\$obj->$function($input_str), $expected_str, " . q_wrap($desc) . ");\n";
2125						}
2126						}
2127						} else {
2128	6	50 50			13	if($status eq 'DIES') {
2129	0	0			0	if($module) {
2130	0				0	$corpus_code .= "dies_ok { $module\::$function($input_str) } " .
2131						"'Corpus $expected dies';\n";
2132						} else {
2133	0				0	$corpus_code .= "dies_ok { $function($input_str) } " .
2134						"'Corpus $expected dies';\n";
2135						}
2136						} elsif($status eq 'WARNS') {
2137	0	0			0	if($module) {
2138	0				0	$corpus_code .= "warnings_exist { $module\::$function($input_str) } qr/./, " .
2139						"'Corpus $expected warns';\n";
2140						} else {
2141	0				0	$corpus_code .= "warnings_exist { $function($input_str) } qr/./, " .
2142						"'Corpus $expected warns';\n";
2143						}
2144						} else {
2145						my $desc = sprintf("$function(%s) returns %s",
2146	6 9 6	50	50		15 14 3	perl_quote((ref $inputs eq 'ARRAY') ? (join(', ', map { $_ // '' } @{$inputs})) : $inputs),
2147						$expected_str
2148						);
2149	6	50	50		12	if(($output{'type'} // '') eq 'boolean') {
2150	0	0 0			0	if($expected_str eq '1') {
2151	0				0	$corpus_code .= "ok(\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
2152						} elsif($expected_str eq '0') {
2153	0				0	$corpus_code .= "ok(!\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
2154						} else {
2155	0				0	croak("Boolean is expected to return $expected_str");
2156						}
2157						} else {
2158	6				13	$corpus_code .= "is(\$obj->$function($input_str), $expected_str, " . q_wrap($desc) . ");\n";
2159						}
2160						}
2161						}
2162						}
2163						}
2164
2165						# Prepare seed/iterations code fragment for the generated test
2166	86				119	my $seed_code = '';
2167	86	100			122	if (defined $seed) {
2168						# ensure integer-ish
2169	7				8	$seed = int($seed);
2170	7				12	$seed_code = "srand($seed);\n";
2171						}
2172
2173	86	100			185	my $determinism_code = 'my $result2;' .
2174						'eval { $result2 = do { ' . (defined($position_code) ? $position_code : $call_code) . " }; };\n" .
2175						'is_deeply($result2, $result, "deterministic result for same input");' .
2176						"\n";
2177
2178						# Generate the test content
2179	86				694	my $tt = Template->new({ ENCODING => 'utf8', TRIM => 1 });
2180
2181						# Read template from DATA handle
2182	86				155416	my $template_package = __PACKAGE__ . '::Template';
2183	86				565	my $template = $template_package->get_data_section('test.tt');
2184
2185						my $vars = {
2186						setup_code => $setup_code,
2187						edge_cases_code => $edge_cases_code,
2188						edge_case_array_code => $edge_case_array_code,
2189						type_edge_cases_code => $type_edge_cases_code,
2190						config_code => $config_code,
2191						seed_code => $seed_code,
2192						input_code => $input_code,
2193						output_code => $output_code,
2194						transforms_code => $transforms_code,
2195						corpus_code => $corpus_code,
2196						call_code => $call_code,
2197						position_code => $position_code,
2198						determinism_code => $determinism_code,
2199						function => $function,
2200						iterations_code => int($iterations),
2201						use_properties => $use_properties,
2202						transform_properties_code => $transform_properties_code,
2203	86		67		109416	property_trials => $config{properties}{trials} // $DEFAULT_PROPERTY_TRIALS,
2204						relationships_code => $relationships_code,
2205						module => $module
2206						};
2207
2208	86				1381	my $test;
2209	86	50			287	$tt->process($template, $vars, \$test) or croak($tt->error());
2210
2211	86	100			1707573	if ($test_file) {
2212						# autodie is disabled for this open -- under "use autodie qw(:all)"
2213						# open() never returns false on failure, it throws its own exception
2214						# instead, which would silently make the "or croak" dead code.
2215	22 22 22			22	102 43 109	no autodie qw(open);
2216	31	50			2535	open my $fh, '>:encoding(UTF-8)', $test_file or croak "Cannot open $test_file: $!";
2217	31				18082	print $fh "$test\n";
2218	31				166	close $fh;
2219	31	100			5976	if($module) {
2220	18				382	print "Generated $test_file for $module\::$function with fuzzing + corpus support\n";
2221						} else {
2222	13				274	print "Generated $test_file for $function with fuzzing + corpus support\n";
2223						}
2224						} else {
2225	55				49187	print "$test\n";
2226						}
2227						}
2228
2229						# --- Helpers for rendering data structures into Perl code for the generated test ---
2230
2231						# --------------------------------------------------
2232						# _is_perl_builtin
2233						#
2234						# Purpose: Return true if a string is the name of
2235						# a Perl core builtin function, to prevent
2236						# it being used as a module name in
2237						# use_ok() calls in generated tests.
2238						#
2239						# Entry: $name - the string to check.
2240						# Exit: Returns 1 if builtin, 0 otherwise.
2241						# --------------------------------------------------
2242						sub _is_perl_builtin {
2243	34			34	11330	my $name = $_[0];
2244	34	100			41	return 0 unless defined $name;
2245
2246	32 404				33 565	state %BUILTINS = map { $_ => 1 } qw(
2247						abs accept alarm atan2 bind binmode bless
2248						caller chdir chmod chomp chop chown chr chroot
2249						close closedir connect cos crypt
2250						dbmclose dbmopen defined delete die do dump
2251						each endgrent endhostent endnetent endprotoent endpwent endservent
2252						eof eval exec exists exit exp
2253						fcntl fileno flock fork format formline
2254						getc getgrent getgrgid getgrnam gethostbyaddr gethostbyname
2255						gethostent getlogin getnetbyaddr getnetbyname getnetent
2256						getpeername getpgrp getppid getpriority getprotobyname
2257						getprotobynumber getprotoent getpwent getpwnam getpwuid
2258						getservbyname getservbyport getservent getsockname getsockopt
2259						glob gmtime goto grep
2260						hex
2261						index int ioctl
2262						join
2263						keys kill
2264						last lc lcfirst length link listen local localtime log lstat
2265						map mkdir msgctl msgget msgrcv msgsnd my
2266						next no
2267						oct open opendir ord our
2268						pack pipe pop pos print printf prototype push
2269						quotemeta
2270						rand read readdir readline readlink readpipe recv redo
2271						ref rename require reset return reverse rewinddir rindex rmdir
2272						say scalar seek seekdir select semctl semget semop send
2273						setgrent sethostent setnetent setpgrp setpriority setprotoent
2274						setpwent setservent setsockopt shift shmctl shmget shmread
2275						shmwrite shutdown sin sleep socket socketpair sort splice split
2276						sprintf sqrt srand stat study sub substr symlink syscall
2277						sysopen sysread sysseek system syswrite
2278						tell telldir tie tied time times truncate
2279						uc ucfirst umask undef unlink unpack unshift untie use
2280						utime values vec wait waitpid wantarray warn write
2281						);
2282	32		100		85	return $BUILTINS{lc $name} // 0;
2283						}
2284
2285						# --------------------------------------------------
2286						# _load_schema
2287						#
2288						# Load and parse a schema file using
2289						# Config::Abstraction, returning the
2290						# schema as a hashref.
2291						#
2292						# Entry: $schema_file - path to the schema file.
2293						# Must be defined, non-empty, and readable.
2294						#
2295						# Exit: Returns a hashref of the parsed schema
2296						# with a '_source' key added containing
2297						# the originating file path.
2298						# Croaks on any error.
2299						#
2300						# Side effects: Reads from the filesystem.
2301						#
2302						# Notes: Legacy Perl-file configs (containing
2303						# '$module' or 'our $module' keys) are
2304						# rejected with a clear error. Config::
2305						# Abstraction is used rather than require()
2306						# to avoid executing arbitrary code from
2307						# user-supplied config files.
2308						# --------------------------------------------------
2309						sub _load_schema {
2310	102			102	8242	my $schema_file = $_[0];
2311
2312						# Validate the argument before touching the filesystem
2313	102	100			236	croak(__PACKAGE__, ': Usage: _load_schema($schema_file)') unless defined $schema_file;
2314
2315	100	100			222	croak(__PACKAGE__, ': _load_schema given empty filename') unless length($schema_file);
2316
2317						# Confirm the file exists and is readable before attempting
2318						# to load it â€” gives a clearer error than Config::Abstraction would
2319	98	100			850	croak(__PACKAGE__, ": _load_schema($schema_file): $!") unless -r $schema_file;
2320
2321						# Load configuration via Config::Abstraction which supports
2322						# YAML, JSON, and other formats without executing arbitrary code.
2323						# no_fixate prevents automatic type coercion that could alter values
2324	93	50			814	if(my $schema = Config::Abstraction->new(
2325						config_dirs => ['.', ''],
2326						config_file => $schema_file,
2327						no_fixate => 1,
2328						)) {
2329	93	50			165342	if($schema = $schema->all()) {
2330						# Detect legacy Perl config files by the presence of
2331						# variable declaration keys â€” these are no longer supported
2332	93	100	67		1358	if(exists($schema->{$LEGACY_PERL_KEY_1}) \|\|
2333						exists($schema->{$LEGACY_PERL_KEY_2})) {
2334	1				10	croak("$schema_file: Loading perl files as configs is no longer supported");
2335						}
2336
2337						# Tag the schema with its source path for error messages
2338	92				938	$schema->{$SOURCE_KEY} = $schema_file;
2339	92				723	return $schema;
2340						}
2341						}
2342
2343	0				0	croak "Failed to load schema from $schema_file";
2344						}
2345
2346						# --------------------------------------------------
2347						# _load_schema_section
2348						#
2349						# Purpose: Extract a named section from a parsed
2350						# schema hashref, validating that it is
2351						# a hashref if present.
2352						#
2353						# Entry: $schema - the full parsed schema hashref.
2354						# $section - name of the section to extract
2355						# (e.g. 'input', 'output').
2356						# $schema_file - path of the schema file,
2357						# used in error messages only.
2358						#
2359						# Exit: Returns the section hashref if present,
2360						# or an empty hashref {} if absent.
2361						# Croaks if the section exists but is not
2362						# a hashref (and not the string 'undef').
2363						#
2364						# Notes: The string 'undef' is treated as an
2365						# absent section â€” callers that set a
2366						# section to 'undef' in YAML get the same
2367						# result as omitting it entirely.
2368						# --------------------------------------------------
2369						sub _load_schema_section {
2370	398			398	5934	my ($schema, $section, $schema_file) = @_;
2371
2372						# Section absent â€” return empty hash as the safe default
2373	398	100			679	return {} unless exists $schema->{$section};
2374
2375						# Section present and is a hashref â€” return it directly
2376						return $schema->{$section}
2377	203	100			623	if ref($schema->{$section}) eq 'HASH';
2378
2379						# Treat the YAML scalar 'undef' as equivalent to absent
2380						return {}
2381						if defined($schema->{$section}) &&
2382	8	100	67		26	$schema->{$section} eq 'undef';
2383
2384						# Section present but wrong type â€” croak with a clear message
2385						# showing what type was found so the user can fix their schema
2386						croak(
2387						"$schema_file: $section should be a hash, not ",
2388	5		67		60	ref($schema->{$section}) \|\| $schema->{$section}
2389						);
2390						}
2391
2392						# --------------------------------------------------
2393						# _validate_config
2394						#
2395						# Purpose: Validate the top-level schema hashref
2396						# loaded from a schema file, checking that
2397						# required fields are present and that all
2398						# input parameters, types, positions, and
2399						# transform properties are well-formed.
2400						#
2401						# Entry: $schema - the full parsed schema hashref
2402						# as returned by _load_schema().
2403						#
2404						# Exit: Returns nothing on success.
2405						# Croaks on any structural error.
2406						# Carps on non-fatal warnings (unknown
2407						# semantic types, position gaps, missing
2408						# input/output definitions).
2409						#
2410						# Side effects: May delete $schema->{input} if its
2411						# value is the string 'undef'.
2412						#
2413						# Notes: The parameter is named $schema throughout
2414						# to distinguish the top-level schema from
2415						# the nested config sub-hash. _validate_config
2416						# is called before _normalize_config so config
2417						# boolean normalisation has not yet occurred.
2418						# --------------------------------------------------
2419						sub _validate_config {
2420	111			111	29277	my $schema = $_[0];
2421
2422						# At least one of module or function must be present â€”
2423						# without these we cannot generate any meaningful test
2424	111	100	100		259	if(!defined($schema->{'module'}) && !defined($schema->{'function'})) {
2425	4				27	croak('At least one of function and module must be defined');
2426						}
2427
2428						# Warn if neither input nor output is defined â€” a few
2429						# generic tests can still be generated but it is unusual
2430	107	100	100		242	if(!defined($schema->{'input'}) && !defined($schema->{'output'})) {
2431	9				54	carp('Neither input nor output is defined, only a few tests will be generated');
2432						}
2433
2434						# Normalise input: the string 'undef' means no input defined
2435	107	100	100		1625	if($schema->{'input'} && ref($schema->{input}) ne 'HASH') {
2436	3	100			5	if($schema->{'input'} eq 'undef') {
2437	1				2	delete $schema->{'input'};
2438						} else {
2439	2				9	croak("Invalid input specification: expected hash, got '$schema->{'input'}'");
2440						}
2441						}
2442
2443						# Validate each input parameter if input is defined
2444	105	100			210	if($schema->{input}) {
2445	91				229	_validate_input_params($schema);
2446	90				287	_validate_input_positions($schema);
2447	90				201	_validate_input_semantics($schema);
2448						}
2449
2450						# Validate transform property definitions if present
2451	104	100	67		326	if(exists($schema->{transforms}) && ref($schema->{transforms}) eq 'HASH') {
2452	11				27	_validate_transform_properties($schema);
2453						}
2454
2455						# Validate any nested config sub-hash keys against known types
2456	104	100			267	if(ref($schema->{config}) eq 'HASH') {
2457	12 12				17 56	for my $k (keys %{$schema->{'config'}}) {
2458						# %VALID_CONFIG_KEYS is the authoritative set â€” O(1) hash lookup
2459						croak "unknown config setting '$k'"
2460	49	100			231	unless $VALID_CONFIG_KEYS{$k};
2461						}
2462						}
2463						}
2464
2465						# --------------------------------------------------
2466						# _validate_input_params
2467						#
2468						# Purpose: Validate type specifications for each
2469						# named input parameter.
2470						#
2471						# Entry: $schema - the full parsed schema hashref.
2472						# $schema->{input} must be a hashref.
2473						#
2474						# Exit: Returns nothing. Croaks on invalid type.
2475						# --------------------------------------------------
2476						sub _validate_input_params {
2477	94			94	4580	my $schema = $_[0];
2478
2479	94 94				112 215	for my $param (keys %{$schema->{input}}) {
2480						# Catch empty parameter names â€” these would produce
2481						# broken Perl variable names in the generated test
2482	95	100			163	croak 'Empty input parameter name'
2483						unless length($param);
2484
2485	94				119	my $spec = $schema->{input}{$param};
2486
2487						# Validate the type field â€” required for all parameters
2488	94	100			131	if(ref($spec)) {
2489						croak("Missing type for parameter '$param'")
2490	41	100			81	unless defined $spec->{type};
2491						# 'coderef' is a SchemaExtractor-specific type; treat as 'any'
2492	40	50			70	$spec->{type} = 'any' if $spec->{type} eq 'coderef';
2493						croak("Invalid type '$spec->{type}' for parameter '$param'")
2494	40	100			119	unless _valid_type($spec->{type});
2495						} else {
2496	53	50			142	croak("Invalid type '$spec' for parameter '$param'")
2497						unless _valid_type($spec);
2498						}
2499						}
2500						}
2501
2502						# --------------------------------------------------
2503						# _validate_input_positions
2504						#
2505						# Purpose: Validate positional argument declarations
2506						# in the input schema â€” positions must be
2507						# non-negative integers with no duplicates,
2508						# and either all or no parameters must have
2509						# positions.
2510						#
2511						# Entry: $schema - the full parsed schema hashref.
2512						# $schema->{input} must be a hashref.
2513						#
2514						# Exit: Returns nothing. Croaks on invalid or
2515						# duplicate positions. Carps on gaps.
2516						# --------------------------------------------------
2517						sub _validate_input_positions {
2518	98			98	6864	my $schema = $_[0];
2519
2520	98				109	my $has_positions = 0;
2521	98				120	my %positions;
2522
2523	98 98				101 183	for my $param (keys %{$schema->{input}}) {
2524	105				127	my $spec = $schema->{input}{$param};
2525
2526						# Only process params that explicitly declare a position
2527	105	100	100		298	next unless ref($spec) eq 'HASH' && defined($spec->{position});
2528
2529	31				30	$has_positions = 1;
2530	31				33	my $pos = $spec->{position};
2531
2532						# Position must be a non-negative integer
2533	31	100			104	croak "Position for '$param' must be a non-negative integer"
2534						unless $pos =~ /^\d+$/;
2535
2536						# Duplicate positions would produce ambiguous generated tests
2537						croak "Duplicate position $pos for parameters '$positions{$pos}' and '$param'"
2538	30	100			55	if exists $positions{$pos};
2539
2540	28				49	$positions{$pos} = $param;
2541						}
2542
2543						# If any param has a position, all params must have one
2544	95	100			178	if($has_positions) {
2545	19 19				21 34	for my $param (keys %{$schema->{input}}) {
2546	27				55	my $spec = $schema->{input}{$param};
2547	27	100	67		90	unless(ref($spec) eq 'HASH' && defined($spec->{position})) {
2548	2				9	croak "Parameter '$param' missing position " .
2549						'(all params must have positions if any do)';
2550						}
2551						}
2552
2553						# Check for gaps â€” positions must be a contiguous sequence
2554						# starting at 0, otherwise the generated test will be wrong
2555	17 7				50 17	my @sorted = sort { $a <=> $b } keys %positions;
2556	17				40	for my $i (0 .. $#sorted) {
2557	24	100			50	if($sorted[$i] != $i) {
2558	1				5	carp "Position sequence has gaps (positions: @sorted)";
2559	1				125	last;
2560						}
2561						}
2562						}
2563						}
2564
2565						# --------------------------------------------------
2566						# _validate_input_semantics
2567						#
2568						# Purpose: Validate semantic type annotations and
2569						# enum/memberof constraints on input params.
2570						#
2571						# Entry: $schema - the full parsed schema hashref.
2572						# $schema->{input} must be a hashref.
2573						#
2574						# Exit: Returns nothing. Croaks on conflicting
2575						# or malformed enum/memberof. Carps on
2576						# unknown semantic types.
2577						# --------------------------------------------------
2578						sub _validate_input_semantics {
2579	100			100	10362	my $schema = $_[0];
2580
2581	100				301	my $semantic_generators = _get_semantic_generators();
2582
2583	100 100				114 243	for my $param (keys %{$schema->{input}}) {
2584	100				141	my $spec = $schema->{input}{$param};
2585	100	100			380	next unless ref($spec) eq 'HASH';
2586
2587						# Warn on unknown semantic types rather than croaking â€”
2588						# new semantic types may be added without updating this list
2589	46	100			78	if(defined($spec->{semantic})) {
2590	4				5	my $semantic = $spec->{semantic};
2591	4	100			6	unless(exists $semantic_generators->{$semantic}) {
2592						carp "Unknown semantic type '$semantic' for parameter '$param'. " .
2593						'Available types: ' .
2594	2 2				4 25	join(', ', sort keys %{$semantic_generators});
2595						}
2596						}
2597
2598						# enum and memberof are mutually exclusive representations
2599						# of the same concept â€” having both is always a schema error
2600	46	100	100		305	if($spec->{'enum'} && $spec->{'memberof'}) {
2601	2				8	croak "$param: has both enum and memberof";
2602						}
2603
2604						# Both enum and memberof must be arrayrefs when present
2605	44				51	for my $type ('enum', 'memberof') {
2606	87	100			229	if(exists $spec->{$type}) {
2607						croak "$type must be an arrayref"
2608	4	100			26	unless ref($spec->{$type}) eq 'ARRAY';
2609						}
2610						}
2611						}
2612						}
2613
2614						# --------------------------------------------------
2615						# _validate_transform_properties
2616						#
2617						# Purpose: Validate the properties array in each
2618						# transform definition, checking that each
2619						# property is either a known builtin name
2620						# or a custom hashref with name and code.
2621						#
2622						# Entry: $schema - the full parsed schema hashref.
2623						# $schema->{transforms} must be a hashref.
2624						#
2625						# Exit: Returns nothing. Croaks on invalid property
2626						# definitions. Carps on unknown builtins.
2627						# --------------------------------------------------
2628						sub _validate_transform_properties {
2629	17			17	7401	my $schema = $_[0];
2630
2631	17				49	my $builtin_props = _get_builtin_properties();
2632
2633	17 17				30 163	for my $transform_name (keys %{$schema->{transforms}}) {
2634	15				14	my $transform = $schema->{transforms}{$transform_name};
2635
2636						# properties is optional â€” skip transforms that don't define it
2637	15	100			114	next unless exists $transform->{properties};
2638
2639						croak "Transform '$transform_name': properties must be an array"
2640	6	100			12	unless ref($transform->{properties}) eq 'ARRAY';
2641
2642	5 5				2 6	for my $prop (@{$transform->{properties}}) {
2643	5	100 100			9	if(!ref($prop)) {
2644						# Plain string â€” must be a known builtin property name
2645	2	100			20	unless(exists $builtin_props->{$prop}) {
2646						carp "Transform '$transform_name': unknown built-in property '$prop'. " .
2647						'Available: ' .
2648	1 1				2 10	join(', ', sort keys %{$builtin_props});
2649						}
2650						} elsif(ref($prop) eq 'HASH') {
2651						# Custom property â€” must have both name and code fields
2652	2	100	67		17	unless($prop->{name} && $prop->{code}) {
2653	1				5	croak "Transform '$transform_name': " .
2654						"custom properties must have 'name' and 'code' fields";
2655						}
2656						} else {
2657	1				4	croak "Transform '$transform_name': invalid property definition";
2658						}
2659						}
2660						}
2661						}
2662
2663						# --------------------------------------------------
2664						# _normalize_config
2665						#
2666						# Purpose: Normalise boolean string values in the
2667						# config sub-hash to Perl integers (1/0),
2668						# and default absent boolean fields to 1
2669						# (enabled). The 'properties' field is a
2670						# hashref not a boolean and is handled
2671						# separately.
2672						#
2673						# Entry: $config - the config sub-hash extracted
2674						# from the schema (i.e. $schema->{config}).
2675						# May be empty.
2676						#
2677						# Exit: Returns nothing. Modifies $config in place.
2678						#
2679						# Side effects: Modifies the caller's config hashref.
2680						#
2681						# Notes: String-to-boolean conversion is delegated
2682						# to %Readonly::Values::Boolean::booleans
2683						# which handles 'yes'/'no', 'on'/'off',
2684						# 'true'/'false' etc. Fields not present in
2685						# the config hash are defaulted to 1 so
2686						# that test generation is maximally thorough
2687						# unless the schema explicitly disables a
2688						# feature.
2689						# --------------------------------------------------
2690						sub _normalize_config {
2691	102			102	11404	my $config = $_[0];
2692
2693	102				436	for my $field (keys %VALID_CONFIG_KEYS) {
2694						# Non-boolean fields are handled separately
2695	918	100			2915	next if $field eq $CONFIG_PROPERTIES_KEY;
2696	816	100			1841	next if $field eq 'timeout'; # numeric, not boolean; absence means use generated-test default
2697
2698	714	100	100		1067	if(exists($config->{$field}) && defined($config->{$field})) {
2699						# Convert string boolean representations to integers
2700						# using the lookup table from Readonly::Values::Boolean
2701	530	50			896	if(defined(my $b = $Readonly::Values::Boolean::booleans{$config->{$field}})) {
2702	530				1834	$config->{$field} = $b;
2703						}
2704						} else {
2705						# Default absent boolean fields to enabled (1) so that
2706						# test generation is comprehensive unless explicitly disabled
2707	184				169	$config->{$field} = 1;
2708						}
2709						}
2710
2711						# Ensure properties is always a hashref â€” if absent or set to
2712						# a non-hash value, replace with a disabled default so that
2713						# downstream code can safely dereference it without checking ref()
2714	102	100			214	$config->{$CONFIG_PROPERTIES_KEY} = { enable => 0 } unless ref($config->{$CONFIG_PROPERTIES_KEY}) eq 'HASH';
2715						}
2716
2717						# --------------------------------------------------
2718						# _valid_type
2719						#
2720						# Determine whether a string is a
2721						# recognised schema field type accepted
2722						# by the generator.
2723						#
2724						# Entry: $type - the type string to validate.
2725						# May be undef.
2726						#
2727						# Exit: Returns 1 if the type is known,
2728						# 0 if the type is unknown or undef.
2729						#
2730						# Notes: The lookup hash is declared with
2731						# 'state' so it is built only once per
2732						# process rather than on every call â€”
2733						# important since _valid_type is called
2734						# in a loop over all input parameters.
2735						#
2736						# 'int' and 'bool' are accepted as
2737						# aliases for 'integer' and 'boolean'
2738						# respectively, for compatibility with
2739						# schemas generated by external tools
2740						# that use the shorter forms.
2741						# --------------------------------------------------
2742						sub _valid_type {
2743	154			154	16630	my $type = $_[0];
2744
2745						# Undef is never a valid type
2746	154	100			222	return 0 unless defined($type);
2747
2748						# Build the lookup table once and cache it for
2749						# the lifetime of the process via 'state'
2750	151 165				168 231	state %VALID = map { $_ => 1 } qw(
2751						string boolean integer number float
2752						hashref arrayref object int bool any
2753						);
2754
2755	151		100		427	return($VALID{$type} // 0);
2756						}
2757
2758						# --------------------------------------------------
2759						# _assert_identifier
2760						#
2761						# Purpose: Validate that a string is shaped like a
2762						# plain Perl identifier (or, with
2763						# package => 1, a "::"-separated package
2764						# name) before it is spliced into generated
2765						# test source as a bareword, package name,
2766						# method name, or variable name rather than
2767						# a quoted string literal. Schema-derived
2768						# names (module, function, transform names)
2769						# are spliced unescaped at the call sites
2770						# that use this guard, so an unvalidated
2771						# name could otherwise break out of the
2772						# generated source and inject arbitrary
2773						# Perl into a file that L<prove> will run.
2774						#
2775						# Entry: $name - the string to validate.
2776						# $what - short label for the value, used
2777						# only in the croak message.
2778						# %opts - package => 1 allows "::"
2779						# separators in $name.
2780						#
2781						# Exit: Returns $name unchanged on success.
2782						# Croaks if $name is not identifier-shaped.
2783						# --------------------------------------------------
2784						sub _assert_identifier {
2785	165			165	9973	my ($name, $what, %opts) = @_;
2786
2787	165	100	100		406	croak(__PACKAGE__, ": $what is missing or empty")
2788						unless defined($name) && length($name);
2789
2790						my $re = $opts{package}
2791	163	100			392	? qr/^[A-Za-z_]\w(?:::[A-Za-z_]\w)*\z/
2792						: qr/^[A-Za-z_]\w*\z/;
2793
2794	163	100			726	croak(__PACKAGE__, ": $what '$name' is not a valid Perl identifier")
2795						unless $name =~ $re;
2796
2797	153				215	return $name;
2798						}
2799
2800						# --------------------------------------------------
2801						# _validate_module
2802						#
2803						# Purpose: Check whether the module named in a
2804						# schema can be found in @INC during
2805						# test generation. Optionally also
2806						# attempts to load it if the
2807						# GENERATOR_VALIDATE_LOAD environment
2808						# variable is set.
2809						#
2810						# Entry: $module - the module name to
2811						# check. If undef or
2812						# empty, returns 1
2813						# immediately (builtin
2814						# functions need no
2815						# module).
2816						# $schema_file - path to the schema
2817						# file, used in warning
2818						# messages only.
2819						#
2820						# Exit: Returns 1 if the module was found
2821						# (and loaded, if validation was
2822						# requested).
2823						# Returns 0 if the module was not
2824						# found or failed to load â€” this is
2825						# non-fatal; generation continues.
2826						# Returns 1 immediately for undef or
2827						# empty $module.
2828						#
2829						# Side effects: Prints to STDERR when TEST_VERBOSE
2830						# or GENERATOR_VERBOSE is set.
2831						# Carps (non-fatally) when the module
2832						# cannot be found or loaded.
2833						# May attempt to load the module into
2834						# the current process when
2835						# GENERATOR_VALIDATE_LOAD is set â€”
2836						# this can have side effects depending
2837						# on the module.
2838						#
2839						# Notes: Not finding a module during generation
2840						# is intentionally non-fatal â€” the module
2841						# may be available on the target machine
2842						# even if not on the generation machine.
2843						# Verbose output goes to STDERR via
2844						# print rather than carp since it is
2845						# informational, not a warning.
2846						# --------------------------------------------------
2847						sub _validate_module {
2848	43			43	7764	my ($module, $schema_file) = @_;
2849
2850						# Builtin functions have no module to validate
2851	43	100			65	return 1 unless $module;
2852
2853						# Check whether the module is findable in @INC
2854	41				166	my $mod_info = check_install(module => $module);
2855
2856	41	100	100		67179	if($schema_file && !$mod_info) {
2857						# Non-fatal â€” emit a single consolidated warning so
2858						# the caller sees one message rather than four
2859	18				553	carp(
2860						"Module '$module' not found in \@INC during generation.\n" .
2861						" Config file: $schema_file\n" .
2862						" This is OK if the module will be available when tests run.\n" .
2863						' If unexpected, check your module name and installation.'
2864						);
2865	18				3161	return 0;
2866						}
2867
2868						# Check once and reuse â€” avoids evaluating two env vars twice
2869	23		33		89	my $verbose = $ENV{$ENV_TEST_VERBOSE} \|\| $ENV{$ENV_GENERATOR_VERBOSE};
2870
2871	23	50			231	if($verbose) {
2872						carp "Found module '$module' at: $mod_info->{'file'} " .
2873	0		0		0	'(version ' . ($mod_info->{'version'} \|\| 'unknown') . ')';
2874						}
2875
2876						# Optional load validation â€” disabled by default because
2877						# loading a module can have side effects (e.g. BEGIN blocks,
2878						# database connections, file I/O) that are undesirable
2879						# during generation
2880	23	100			45	if($ENV{$ENV_VALIDATE_LOAD}) {
2881	1				10	my $loaded = can_load(modules => { $module => undef }, verbose => 0);
2882
2883	1	50			5679	if(!$loaded) {
2884	0		0		0	my $err = $Module::Load::Conditional::ERROR \|\| 'unknown error';
2885	0				0	carp(
2886						"Module '$module' found but failed to load: $err\n" .
2887						' This might indicate a broken installation or missing dependencies.'
2888						);
2889	0				0	return 0;
2890						}
2891
2892	1	50			2	if($verbose) {
2893	0				0	carp "Successfully loaded module '$module'";
2894						}
2895						}
2896
2897	23				118	return 1;
2898						}
2899
2900 - 2946						=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
2947
2948						sub render_fallback {
2949	38			38	7703	my $v = $_[0];
2950
2951						# Handle undef explicitly rather than letting Dumper produce
2952						# 'undef' without the localised settings applied
2953	38	100			61	return 'undef' unless defined $v;
2954
2955						# Use Terse+Indent=0 to produce compact single-line output
2956						# suitable for embedding in generated test code
2957	28				69	local $Data::Dumper::Terse = 1;
2958	28				50	local $Data::Dumper::Indent = 0;
2959
2960	28				101	my $s = Dumper($v);
2961
2962						# Remove trailing newline that Dumper always appends
2963	28				1253	chomp $s;
2964	28				64	return $s;
2965						}
2966
2967 - 3017						=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
3018
3019						sub render_hash {
3020	58			58	18326	my $href = $_[0];
3021
3022						# Return empty string for absent or non-hash input â€” callers
3023						# treat '' as "no input specification" in the generated test
3024	58	100	100		191	return '' unless $href && ref($href) eq 'HASH';
3025
3026	53				53	my @lines;
3027
3028	53 53				55 102	for my $k (sort keys %{$href}) {
3029	44				55	my $def = $href->{$k};
3030
3031						# Handle scalar shorthand â€” 'arg1: string' is equivalent to
3032						# 'arg1: { type: string }' and is explicitly supported by the
3033						# validation layer in _validate_input_params
3034	44	100	67		145	unless(defined($def) && ref($def) eq 'HASH') {
3035	6	100	50		27	if(defined($def) && !ref($def) && _valid_type($def)) {
3036						# Expand scalar type shorthand to a full spec hashref
3037	4				6	$def = { type => $def };
3038						} else {
3039	2				26	carp "render_hash: skipping key '$k' â€” value is not a hashref or recognised type string";
3040	2				232	next;
3041						}
3042						}
3043
3044	42				58	my @pairs;
3045
3046	42 42				44 97	for my $subk (sort keys %{$def}) {
3047						# Skip undef sub-values â€” they contribute nothing to the spec
3048	85	100			104	next unless defined $def->{$subk};
3049
3050						# Validate that reference types are ones we can render â€”
3051						# nested hashrefs are not yet supported
3052	84	50			104	if(ref($def->{$subk})) {
3053	0	0	0		0	unless((ref($def->{$subk}) eq 'ARRAY') \|\|
3054						(ref($def->{$subk}) eq 'Regexp')) {
3055						croak(
3056						__PACKAGE__,
3057						": $subk is a nested element, not yet supported (",
3058	0				0	ref($def->{$subk}), ')'
3059						);
3060						}
3061						}
3062
3063						# matches and nomatch values must be Regexp objects in the
3064						# generated test â€” compile raw strings safely via eval so
3065						# patterns containing [ or \ don't cause compile failures
3066	84	100	67		126	if(($subk eq $KEY_MATCHES) \|\| ($subk eq $KEY_NOMATCH)) {
3067						my $re = ref($def->{$subk}) eq 'Regexp'
3068						? $def->{$subk}
3069	3 3	50			19 47	: eval { qr/$def->{$subk}/ };
3070	3	50	33		11	if($@ \|\| !defined($re)) {
3071	0				0	carp "render_hash: invalid $subk pattern '$def->{$subk}': $@";
3072	0				0	next;
3073						}
3074	3				8	push @pairs, "$subk => " . perl_quote($re);
3075						} else {
3076						# All other sub-keys are rendered via perl_quote which
3077						# handles scalars, arrayrefs, and Regexp objects correctly
3078	81				459	push @pairs, "$subk => " . perl_quote($def->{$subk});
3079						}
3080						}
3081
3082						# Use "\t" rather than a literal tab for clarity and grep-ability
3083	42				73	push @lines, "\t" . perl_quote($k) . ' => { ' . join(', ', @pairs) . ' }';
3084						}
3085
3086	53				108	return join(",\n", @lines);
3087						}
3088
3089 - 3131						=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
3132
3133						sub render_args_hash {
3134	126			126	11422	my $href = $_[0];
3135
3136						# Return empty string for absent or non-hash input
3137	126	100	100		344	return '' unless $href && ref($href) eq 'HASH';
3138
3139						# Sort keys for deterministic output across runs â€” important for
3140						# generated test files that are committed to version control
3141						my @pairs = map {
3142	141				210	perl_quote($_) . ' => ' . perl_quote($href->{$_})
3143	122 122				122 163	} sort keys %{$href};
3144
3145	122				250	return join(', ', @pairs);
3146						}
3147
3148 - 3190						=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
3191
3192						sub render_arrayref_map {
3193	191			191	13602	my $href = $_[0];
3194
3195						# Return '()' rather than '' so callers get a valid empty hash
3196						# literal rather than a syntax error in the generated test
3197	191	100	67		471	return '()' unless $href && ref($href) eq 'HASH';
3198
3199	188				143	my @entries;
3200
3201	188 188				172 267	for my $k (sort keys %{$href}) {
3202	10				11	my $aref = $href->{$k};
3203
3204						# Skip non-arrayref values â€” mixed hashes are allowed by callers
3205	10	100			15	next unless ref($aref) eq 'ARRAY';
3206
3207						# Render each array element via perl_quote so strings are
3208						# properly quoted and numbers are left unquoted
3209	7 12 7				6 12 8	my $vals = join(', ', map { perl_quote($_) } @{$aref});
3210
3211						# Use "\t" rather than a literal tab for clarity
3212	7				10	push @entries, "\t" . perl_quote($k) . " => [ $vals ]";
3213						}
3214
3215	188				311	return join(",\n", @entries);
3216						}
3217
3218						# --------------------------------------------------
3219						# _has_positions
3220						#
3221						# Purpose: Determine whether any field in an input
3222						# spec hashref declares a positional argument
3223						# via the 'position' key.
3224						#
3225						# Entry: $input_spec - the input section of a parsed
3226						# schema, expected to be a hashref whose values
3227						# are themselves hashrefs containing field specs.
3228						# May be undef or a non-hash ref.
3229						#
3230						# Exit: Returns 1 if any field has a defined
3231						# 'position' key, 0 otherwise.
3232						#
3233						# Notes: Returns 0 immediately for undef or non-hash
3234						# input rather than throwing â€” callers use the
3235						# return value as a boolean and do not expect
3236						# exceptions from this function.
3237						# --------------------------------------------------
3238						sub _has_positions {
3239	113			113	12578	my $input_spec = $_[0];
3240
3241						# Guard against undef or non-hash input â€” keys %$undef would throw
3242	113	100	100		337	return 0 unless defined($input_spec) && ref($input_spec) eq 'HASH';
3243
3244	109 109				96 165	for my $field (keys %{$input_spec}) {
3245						# Only examine fields whose spec is a hashref â€” scalar specs
3246						# (e.g. input: { type: string }) cannot have positions
3247	96	100			192	next unless ref($input_spec->{$field}) eq 'HASH';
3248
3249						# Return immediately on first match â€” no need to scan further
3250	43	100			84	return 1 if defined $input_spec->{$field}{position};
3251						}
3252
3253						# No positional arguments found in any field
3254	82				121	return 0;
3255						}
3256
3257						# --------------------------------------------------
3258						# q_wrap
3259						#
3260						# Purpose: Wrap a string in the most readable
3261						# q{} form that does not require escaping,
3262						# falling back to single-quoted form with
3263						# escaped apostrophes if no delimiter is
3264						# available.
3265						#
3266						# Entry: $s - the string to wrap. May be undef.
3267						# Exit: Returns a Perl source-code fragment that
3268						# evaluates to the original string value,
3269						# or the string 'undef' if $s is undef.
3270						#
3271						# Notes: index() returns -1 when not found and
3272						# any value >= 0 when found, including 0
3273						# for a delimiter at the start of the
3274						# string. We compare against $INDEX_NOT_FOUND
3275						# to make this boundary explicit and to
3276						# prevent off-by-one mutation survivors.
3277						# See GitHub issue #1.
3278						# --------------------------------------------------
3279						sub q_wrap {
3280	123			123	20574	my $s = $_[0];
3281
3282	123	50			132	croak('q_wrap: argument must be a plain string, not a reference') if ref($s);
3283
3284						# Return empty string for undef â€” this function is a low-level
3285						# string quoter only. Callers that need the Perl literal 'undef'
3286						# for undefined values should use perl_quote() instead, which
3287						# handles the undef -> 'undef' semantic conversion correctly.
3288						# Returning '' here preserves the original behaviour and avoids
3289						# injecting the bare word 'undef' into contexts that expect a
3290						# quoted string value.
3291	123	100			110	return "''" unless defined $s;
3292
3293						# Try bracket-form q{} delimiters first â€” most readable
3294	120				241	for my $p (@Q_BRACKET_PAIRS) {
3295	137 137				333 155	my ($l, $r) = @{$p};
3296
3297						# Only use this bracket pair if neither bracket
3298						# appears in the string â€” both must be checked
3299	137	100			1856	return "q$l$s$r" unless $s =~ /\Q$l\E\|\Q$r\E/;
3300						}
3301
3302						# Try single-character delimiters in preference order
3303	4				13	for my $d (@Q_SINGLE_DELIMITERS) {
3304						# index() returns $INDEX_NOT_FOUND (-1) when not found.
3305						# Must use != $INDEX_NOT_FOUND rather than > 0 since
3306						# the delimiter may legitimately appear at position 0
3307	26	100			129	return "q$d$s$d" if index($s, $d) == $INDEX_NOT_FOUND;
3308						}
3309
3310						# Last resort â€” single-quoted string with escaped apostrophes
3311	2				15	(my $esc = $s) =~ s/'/\\'/g;
3312	2				6	return "'$esc'";
3313						}
3314
3315						# --------------------------------------------------
3316						# perl_sq
3317						#
3318						# Purpose: Escape a string for safe inclusion
3319						# inside a single-quoted Perl string
3320						# literal in generated test code.
3321						#
3322						# Entry: $s - the string to escape.
3323						# Exit: Returns the escaped string, or an
3324						# empty string if $s is undef.
3325						#
3326						# Notes: NUL byte replacement produces the
3327						# two-character sequence \0 which is
3328						# only correct when the result is used
3329						# inside a double-quoted string context
3330						# in the generated test.
3331						#
3332						# The \b substitution (backspace) is
3333						# intentionally omitted â€” in Perl regex
3334						# context \b means word boundary, not
3335						# backspace, so substituting it here
3336						# would corrupt strings containing word
3337						# boundaries.
3338						# --------------------------------------------------
3339						sub perl_sq {
3340	398			398	222066	my $s = $_[0];
3341
3342	398	50			341	croak('perl_sq: argument must be a plain string, not a reference') if ref($s);
3343
3344						# Return empty string for undef â€” callers that need
3345						# 'undef' literal should use perl_quote instead
3346	398	100			352	return '' unless defined $s;
3347
3348						# Escape backslashes first so later substitutions
3349						# don't double-escape already-escaped sequences
3350	396				358	$s =~ s/\\/\\\\/g;
3351
3352						# Escape apostrophes so they don't terminate the
3353						# surrounding single-quoted string literal
3354	396				302	$s =~ s/'/\\'/g;
3355
3356						# Escape common control characters to their
3357						# printable two-character escape sequences
3358	396				291	$s =~ s/\n/\\n/g;
3359	396				297	$s =~ s/\r/\\r/g;
3360	396				299	$s =~ s/\t/\\t/g;
3361	396				271	$s =~ s/\f/\\f/g;
3362
3363						# Replace NUL bytes with \0 â€” valid only in
3364						# double-quoted string context in generated code
3365	396				289	$s =~ s/\0/\\0/g;
3366
3367	396				832	return $s;
3368						}
3369
3370 - 3400						=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
3401
3402						sub perl_quote {
3403	500			500	271505	my ($v) = @_;
3404	500				529	return _perl_quote($v, 0);
3405						}
3406
3407						sub _perl_quote {
3408	625			625	485	my ($v, $depth) = @_;
3409	22 22 22			22	51242 21 45999	no warnings 'recursion'; ## no critic (TestingAndDebugging::ProhibitNoWarnings)
3410	625	100			584	croak('perl_quote: structure too deeply nested (circular reference?)') if $depth > 100;
3411
3412						# Undef produces the Perl literal 'undef'
3413	624	100			505	return 'undef' unless defined $v;
3414
3415						# Convert YAML boolean string literals to Perl
3416						# boolean constants so they survive round-tripping
3417	619	100			573	return '!!1' if $v eq 'true';
3418	616	100			542	return '!!0' if $v eq 'false';
3419
3420	613	100			509	if(ref($v)) {
3421						# Recursively quote each element of an arrayref
3422	141	100			157	if(ref($v) eq 'ARRAY') {
3423	111 125 111				91 157 73	my @quoted_v = map { _perl_quote($_, $depth + 1) } @{$v};
3424	10				26	return '[ ' . join(', ', @quoted_v) . ' ]';
3425						}
3426
3427						# Render Regexp objects as qr{} with modifiers
3428	30	100			55	if(ref($v) eq 'Regexp') {
3429	12				33	my ($pat, $mods) = regexp_pattern($v);
3430	12				14	my $re = "qr{$pat}";
3431
3432						# Append modifiers (e.g. 'i', 'x') if present
3433	12	100			96	$re .= $mods if $mods;
3434	12				29	return $re;
3435						}
3436
3437						# Hashrefs and other reference types fall through
3438						# to render_fallback which uses Data::Dumper
3439	18				38	return render_fallback($v);
3440						}
3441
3442						# Numeric values are emitted unquoted so the generated
3443						# test performs numeric rather than string comparison
3444	472	100			850	return looks_like_number($v) ? $v : "'" . perl_sq($v) . "'";
3445						}
3446
3447						# --------------------------------------------------
3448						# _generate_transform_properties
3449						#
3450						# Convert a hashref of transform
3451						# specifications into an arrayref of
3452						# LectroTest property definition hashrefs,
3453						# one per transform. Each hashref contains
3454						# all the information needed by
3455						# _render_properties to emit a runnable
3456						# Test::LectroTest property block.
3457						#
3458						# Entry: $transforms - hashref of transform name
3459						# => transform spec, as
3460						# loaded from the schema.
3461						# $function - name of the function under
3462						# test.
3463						# $module - module name, or undef for
3464						# builtin functions.
3465						# $input - the top-level input spec
3466						# hashref from the schema
3467						# (used for position sorting).
3468						# $config - the normalised config
3469						# hashref, used to read
3470						# properties.trials.
3471						# $new - defined if the function is
3472						# an object method; the value
3473						# is not used here since
3474						# property tests always
3475						# construct a fresh object
3476						# via new_ok() with no args.
3477						# Presence vs absence is the
3478						# only signal used.
3479						#
3480						# Exit: Returns an arrayref of property hashrefs.
3481						# Returns an empty arrayref if no transforms
3482						# produce any testable properties.
3483						# Never returns undef.
3484						#
3485						# Notes: Transforms whose input is the string
3486						# 'undef' or whose input spec is not a
3487						# hashref are silently skipped â€” they
3488						# represent error-case transforms that have
3489						# no meaningful generator.
3490						#
3491						# The 'WARN' vs 'WARNS' distinction in
3492						# _STATUS: the schema convention uses
3493						# 'WARNS' throughout. This function checks
3494						# for 'WARNS' to match that convention.
3495						# --------------------------------------------------
3496						sub _generate_transform_properties {
3497	11			11	9219	my ($transforms, $function, $module, $input, $config, $new) = @_;
3498
3499	11				11	my @properties;
3500
3501	11 11				7 18	for my $transform_name (sort keys %{$transforms}) {
3502						# $transform_name is spliced by _render_properties as a Perl
3503						# variable name (my $$transform_name = Property {...}), not
3504						# just inside a string literal â€” reject anything that isn't
3505						# identifier-shaped before it reaches that point.
3506	13				19	_assert_identifier($transform_name, 'transform name');
3507
3508	12				11	my $transform = $transforms->{$transform_name};
3509
3510	12				12	my $input_spec = $transform->{input};
3511
3512						# Guard: skip transforms with no input or with the
3513						# YAML scalar 'undef' as their input â€” these have no
3514						# generator and cannot produce meaningful properties
3515	12	100	75		27	if(!defined($input_spec) \|\|
3516						(!ref($input_spec) && $input_spec eq 'undef')) {
3517	2				3	next;
3518						}
3519
3520						# Guard: skip transforms whose input is not a hashref â€”
3521						# must come before the helper calls below so we never
3522						# pass a non-hash to _detect_transform_properties or
3523						# _process_custom_properties
3524	10	100			31	next unless ref($input_spec) eq 'HASH';
3525
3526						# Default output spec to empty hash so _STATUS lookups
3527						# below are always safe regardless of schema content
3528	9		50		20	my $output_spec = $transform->{output} // {};
3529
3530						# Detect automatic properties from the transform spec
3531						# (range constraints, type preservation, definedness)
3532	9				13	my @detected_props = _detect_transform_properties(
3533						$transform_name,
3534						$input_spec,
3535						$output_spec
3536						);
3537
3538						# Process any custom properties defined in the schema
3539	9				7	my @custom_props = ();
3540	9	50	33		15	if(exists($transform->{properties}) &&
3541						ref($transform->{properties}) eq 'ARRAY') {
3542						@custom_props = _process_custom_properties(
3543						$transform->{properties},
3544	0				0	$function,
3545						$module,
3546						$input_spec,
3547						$output_spec,
3548						$new
3549						);
3550						}
3551
3552						# Combine auto-detected and custom properties into one list
3553	9				9	my @all_props = (@detected_props, @custom_props);
3554
3555						# Skip this transform if no properties were produced â€”
3556						# nothing useful to render into the generated test
3557	9	50			12	next unless @all_props;
3558
3559						# Build the LectroTest generator specification string,
3560						# one entry per input field that has a generator
3561	9				7	my @generators;
3562						my @var_names;
3563
3564	9 9				8 10	for my $field (sort keys %{$input_spec}) {
3565	9				6	my $spec = $input_spec->{$field};
3566
3567						# Skip non-hashref field specs â€” scalar types
3568						# like 'string' have no generator sub-structure
3569	9	50			12	next unless ref($spec) eq 'HASH';
3570
3571						# $field is spliced unescaped into the generated
3572						# LectroTest generator spec by
3573						# _schema_to_lectrotest_generator() â€” reject anything
3574						# that isn't identifier-shaped first.
3575	9				11	_assert_identifier($field, 'input field name');
3576
3577	9				10	my $gen = _schema_to_lectrotest_generator($field, $spec);
3578	9	50	33		33	if(defined($gen) && length($gen)) {
3579	9				8	push @generators, $gen;
3580	9				11	push @var_names, $field;
3581						}
3582						}
3583
3584	9				9	my $gen_spec = join(', ', @generators);
3585
3586						# Build the call expression for the function under test.
3587						# Note: property tests always construct a fresh object
3588						# via new_ok() with no constructor arguments, regardless
3589						# of what $new holds in the caller â€” the intent here is
3590						# to test the method in isolation, not with specific
3591						# construction state.
3592	9				6	my $call_code;
3593	9	100 50	33 67		38	if($module && defined($new)) {
3594						# OO mode â€” construct a fresh object for each trial
3595	1				1	$call_code = "my \$obj = new_ok('$module');";
3596	1				2	$call_code .= "\$obj->$function";
3597						} elsif($module && $module ne $MODULE_BUILTIN) {
3598						# Functional mode with a named module
3599	0				0	$call_code = "$module\::$function";
3600						} else {
3601						# Builtin or unqualified function call
3602	8				7	$call_code = $function;
3603						}
3604
3605						# Build the argument list, respecting positional order
3606						# if the input spec declares positions
3607	9				5	my @args;
3608	9	50			14	if(_has_positions($input_spec)) {
3609						# Sort fields by declared position so the generated
3610						# call passes arguments in the correct order
3611						my @sorted = sort {
3612						$input_spec->{$a}{position} <=>
3613						$input_spec->{$b}{position}
3614	9 0 9				7 0 15	} keys %{$input_spec};
3615	9 9				9 13	@args = map { "\$$_" } @sorted;
3616						} else {
3617						# No positions â€” use alphabetical order from @var_names
3618	0 0				0 0	@args = map { "\$$_" } @var_names;
3619						}
3620
3621	9				11	my $args_str = join(', ', @args);
3622
3623						# Concatenate all property check expressions with &&
3624						# so the generated property block passes only when
3625						# every check holds
3626	9 29				9 27	my @checks = map { $_->{code} } @all_props;
3627	9				11	my $property_checks = join(" &&\n\t", @checks);
3628
3629						# Determine expected behaviour from output _STATUS.
3630						# Note: the schema convention uses 'WARNS' not 'WARN'
3631	9		100		18	my $should_die = ($output_spec->{'_STATUS'} // '') eq 'DIES';
3632	9		100		15	my $should_warn = ($output_spec->{'_STATUS'} // '') eq 'WARNS';
3633
3634						push @properties, {
3635						name => $transform_name,
3636						generator_spec => $gen_spec,
3637						call_code => "$call_code($args_str)",
3638						property_checks => $property_checks,
3639						should_die => $should_die,
3640						should_warn => $should_warn,
3641	9		33		43	trials => $config->{'properties'}{'trials'} // $DEFAULT_PROPERTY_TRIALS,
3642						};
3643						}
3644
3645	10				19	return \@properties;
3646						}
3647
3648						# --------------------------------------------------
3649						# _get_semantic_generators
3650						#
3651						# Return a hashref of named semantic
3652						# generator definitions for use in
3653						# LectroTest property-based tests.
3654						# Each entry contains a 'code' key
3655						# holding a Gen {} block string and a
3656						# 'description' key for documentation
3657						# and validation messages.
3658						#
3659						# Entry: None.
3660						#
3661						# Exit: Returns a hashref keyed by semantic
3662						# type name. Each value is a hashref
3663						# with 'code' and 'description' keys.
3664						#
3665						# Notes: The returned hashref is built fresh
3666						# on every call â€” callers that need it
3667						# repeatedly should cache the result.
3668						# The 'code' strings are multi-line
3669						# Gen {} blocks; callers are responsible
3670						# for compressing whitespace before
3671						# embedding them in generated test files.
3672						# --------------------------------------------------
3673						sub _get_semantic_generators {
3674						return {
3675	105			105	7155	email => {
3676						code => q{
3677						Gen {
3678						my $len = 5 + int(rand(10));
3679						my @addr;
3680						my @tlds = qw(com org net edu gov io co uk de fr);
3681
3682						for(my $i = 0; $i < $len; $i++) {
3683						push @addr, pack('c', (int(rand 26))+97);
3684						}
3685						push @addr, '@';
3686						$len = 5 + int(rand(10));
3687						for(my $i = 0; $i < $len; $i++) {
3688						push @addr, pack('c', (int(rand 26))+97);
3689						}
3690						push @addr, '.';
3691						$len = rand($#tlds+1);
3692						push @addr, $tlds[$len];
3693						return join('', @addr);
3694						}
3695						},
3696						description => 'Valid email addresses',
3697						}, url => {
3698						code => q{
3699						Gen {
3700						my @schemes = qw(http https);
3701						my @tlds = qw(com org net io);
3702						my $scheme = $schemes[int(rand(@schemes))];
3703						my $domain = join('', map { ('a'..'z')[int(rand(26))] } 1..(5 + int(rand(10))));
3704						my $tld = $tlds[int(rand(@tlds))];
3705						my $path = join('', map { ('a'..'z', '0'..'9', '-', '_')[int(rand(38))] } 1..int(rand(20)));
3706
3707						return "$scheme://$domain.$tld" . ($path ? "/$path" : '');
3708						}
3709						},
3710						description => 'Valid HTTP/HTTPS URLs',
3711						}, uuid => {
3712						code => q{
3713						Gen {
3714						require UUID::Tiny;
3715						UUID::Tiny::create_uuid_as_string(UUID::Tiny::UUID_V4());
3716						}
3717						},
3718						description => 'Valid UUIDv4 identifiers',
3719						}, phone_us => {
3720						code => q{
3721						Gen {
3722						my $area = 200 + int(rand(800));
3723						my $exchange = 200 + int(rand(800));
3724						my $subscriber = int(rand(10000));
3725						sprintf('%03d-%03d-%04d', $area, $exchange, $subscriber);
3726						}
3727						},
3728						description => 'US phone numbers (XXX-XXX-XXXX format)',
3729						}, phone_e164 => {
3730						code => q{
3731						Gen {
3732						my $country = 1 + int(rand(999));
3733						my $area = 100 + int(rand(900));
3734						my $number = int(rand(10000000));
3735						sprintf('+%d%03d%07d', $country, $area, $number);
3736						}
3737						},
3738						description => 'E.164 international phone numbers',
3739						}, ipv4 => {
3740						code => q{
3741						Gen {
3742						join('.', map { int(rand(256)) } 1..4);
3743						}
3744						},
3745						description => 'IPv4 addresses',
3746						}, ipv6 => {
3747						code => q{
3748						Gen {
3749						join(':', map { sprintf('%04x', int(rand(0x10000))) } 1..8);
3750						}
3751						},
3752						description => 'IPv6 addresses',
3753						}, username => {
3754						code => q{
3755						Gen {
3756						my $len = 3 + int(rand(13));
3757						my @chars = ('a'..'z', '0'..'9', '_', '-');
3758						my $first = ('a'..'z')[int(rand(26))];
3759						$first . join('', map { $chars[int(rand(@chars))] } 1..($len-1));
3760						}
3761						},
3762						description => 'Valid usernames (alphanumeric with _ and -)',
3763						}, slug => {
3764						code => q{
3765						Gen {
3766						my @words = qw(quick brown fox jumps over lazy dog hello world test data);
3767						my $count = 1 + int(rand(4));
3768						join('-', map { $words[int(rand(@words))] } 1..$count);
3769						}
3770						},
3771						description => 'URL slugs (lowercase words separated by hyphens)',
3772						}, hex_color => {
3773						code => q{
3774						Gen {
3775						sprintf('#%06x', int(rand(0x1000000)));
3776						}
3777						},
3778						description => 'Hex color codes (#RRGGBB)',
3779						}, iso_date => {
3780						code => q{
3781						Gen {
3782						my $year = 2000 + int(rand(25));
3783						my $month = 1 + int(rand(12));
3784						my $day = 1 + int(rand(28));
3785						sprintf('%04d-%02d-%02d', $year, $month, $day);
3786						}
3787						},
3788						description => 'ISO 8601 date format (YYYY-MM-DD)',
3789						},
3790						iso_datetime => {
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						my $hour = int(rand(24));
3797						my $minute = int(rand(60));
3798						my $second = int(rand(60));
3799						sprintf('%04d-%02d-%02dT%02d:%02d:%02dZ',
3800						$year, $month, $day, $hour, $minute, $second);
3801						}
3802						},
3803						description => 'ISO 8601 datetime format (YYYY-MM-DDTHH:MM:SSZ)',
3804						}, semver => {
3805						code => q{
3806						Gen {
3807						my $major = int(rand(10));
3808						my $minor = int(rand(20));
3809						my $patch = int(rand(50));
3810						"$major.$minor.$patch";
3811						}
3812						},
3813						description => 'Semantic version strings (major.minor.patch)',
3814						}, jwt => {
3815						code => q{
3816						Gen {
3817						my @chars = ('A'..'Z', 'a'..'z', '0'..'9', '-', '_');
3818						my $header = join('', map { $chars[int(rand(@chars))] } 1..20);
3819						my $payload = join('', map { $chars[int(rand(@chars))] } 1..40);
3820						my $signature = join('', map { $chars[int(rand(@chars))] } 1..30);
3821						"$header.$payload.$signature";
3822						}
3823						},
3824						description => 'JWT-like tokens (base64url format)',
3825						}, json => {
3826						code => q{
3827						Gen {
3828						my @keys = qw(id name value status count);
3829						my $key = $keys[int(rand(@keys))];
3830						my $value = 1 + int(rand(1000));
3831						qq({"$key":$value});
3832						}
3833						},
3834						description => 'Simple JSON objects',
3835						}, base64 => {
3836						code => q{
3837						Gen {
3838						my @chars = ('A'..'Z', 'a'..'z', '0'..'9', '+', '/');
3839						my $len = 12 + int(rand(20));
3840						my $str = join('', map { $chars[int(rand(@chars))] } 1..$len);
3841						$str .= '=' x (4 - ($len % 4)) if $len % 4;
3842						$str;
3843						}
3844						},
3845						description => 'Base64-encoded strings',
3846						}, md5 => {
3847						code => q{
3848						Gen {
3849						join('', map { sprintf('%x', int(rand(16))) } 1..32);
3850						}
3851						},
3852						description => 'MD5 hashes (32 hex characters)',
3853						}, sha256 => {
3854						code => q{
3855						Gen {
3856						join('', map { sprintf('%x', int(rand(16))) } 1..64);
3857						}
3858						},
3859						description => 'SHA-256 hashes (64 hex characters)',
3860						}, unix_timestamp => {
3861						code => q{
3862						Gen {
3863						time;
3864						}
3865						},
3866						description => 'Unix timestamps (seconds since epoch)',
3867						},
3868						};
3869						}
3870
3871						# --------------------------------------------------
3872						# _get_builtin_properties
3873						#
3874						# Purpose: Return a hashref of named built-in
3875						# property templates that can be
3876						# referenced by name in a transform's
3877						# 'properties' list in the schema.
3878						# Each entry contains a 'description'
3879						# string, a 'code_template' coderef, and
3880						# an 'applicable_to' arrayref.
3881						#
3882						# Entry: None.
3883						#
3884						# Exit: Returns a hashref keyed by property
3885						# name. Each value is a hashref with
3886						# 'description', 'code_template', and
3887						# 'applicable_to' keys.
3888						#
3889						# Notes: 'applicable_to' lists the types for
3890						# which each property is meaningful. It
3891						# is stored for documentation purposes
3892						# and potential future filtering â€” it is
3893						# not currently enforced by any caller.
3894						#
3895						# Each 'code_template' coderef receives
3896						# three arguments: ($function, $call_code,
3897						# $input_vars). Most templates use only
3898						# $call_code; $function and $input_vars
3899						# are provided for templates that need
3900						# them (e.g. idempotent, length_preserved,
3901						# preserves_keys).
3902						#
3903						# 'monotonic_increasing' has been
3904						# intentionally omitted. A correct
3905						# implementation requires calling the
3906						# function twice with ordered inputs,
3907						# which the current single-call property
3908						# framework does not support. A
3909						# placeholder that unconditionally returns
3910						# true would give false confidence and has
3911						# therefore been removed.
3912						# --------------------------------------------------
3913						sub _get_builtin_properties {
3914						return {
3915						idempotent => {
3916						description => 'Function is idempotent: f(f(x)) == f(x)',
3917						code_template => sub {
3918	2			2	11018	my ($function, $call_code, $input_vars) = @_;
3919
3920						# String comparison works for all scalar types in Perl â€”
3921						# numeric values stringify consistently for eq
3922	2				5	return "do { my \$tmp = $call_code; \$result eq \$tmp }";
3923						},
3924						applicable_to => ['all'],
3925						}, non_negative => {
3926						description => 'Result is always non-negative',
3927						code_template => sub {
3928	3			3	234	my ($function, $call_code, $input_vars) = @_;
3929	3				4	return '$result >= 0';
3930						},
3931						applicable_to => ['number', 'integer', 'float'],
3932						}, positive => {
3933						description => 'Result is always positive (> 0)',
3934						code_template => sub {
3935	2			2	244	my ($function, $call_code, $input_vars) = @_;
3936	2				2	return '$result > 0';
3937						},
3938						applicable_to => ['number', 'integer', 'float'],
3939						}, non_empty => {
3940						description => 'Result is never empty',
3941						code_template => sub {
3942	2			2	223	my ($function, $call_code, $input_vars) = @_;
3943	2				3	return 'length($result) > 0';
3944						},
3945						applicable_to => ['string'],
3946						},
3947
3948						length_preserved => {
3949						description => 'Output length equals input length',
3950						code_template => sub {
3951	2			2	227	my ($function, $call_code, $input_vars) = @_;
3952	2				2	my $first_var = $input_vars->[0];
3953	2				4	return "length(\$result) == length(\$$first_var)";
3954						},
3955						applicable_to => ['string'],
3956						},
3957
3958						uppercase => {
3959						description => 'Result is all uppercase',
3960						code_template => sub {
3961	2			2	224	my ($function, $call_code, $input_vars) = @_;
3962	2				3	return '$result eq uc($result)';
3963						},
3964						applicable_to => ['string'],
3965						},
3966
3967						lowercase => {
3968						description => 'Result is all lowercase',
3969						code_template => sub {
3970	2			2	222	my ($function, $call_code, $input_vars) = @_;
3971	2				4	return '$result eq lc($result)';
3972						},
3973						applicable_to => ['string'],
3974						},
3975
3976						trimmed => {
3977						description => 'Result has no leading or trailing whitespace',
3978						code_template => sub {
3979	2			2	222	my ($function, $call_code, $input_vars) = @_;
3980	2				3	return '$result !~ /^\s/ && $result !~ /\s$/';
3981						},
3982						applicable_to => ['string'],
3983						},
3984
3985						sorted_ascending => {
3986						description => 'Array is sorted in ascending order',
3987						code_template => sub {
3988	2			2	220	my ($function, $call_code, $input_vars) = @_;
3989	2				4	return 'do { my @arr = @$result; my $sorted = 1; ' .
3990						'for my $i (1..$#arr) { $sorted = 0 if $arr[$i] < $arr[$i-1]; } ' .
3991						'$sorted }';
3992						},
3993						applicable_to => ['arrayref'],
3994						},
3995
3996						sorted_descending => {
3997						description => 'Array is sorted in descending order',
3998						code_template => sub {
3999	2			2	221	my ($function, $call_code, $input_vars) = @_;
4000	2				3	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						unique_elements => {
4008						description => 'Array has no duplicate elements',
4009						code_template => sub {
4010	2			2	224	my ($function, $call_code, $input_vars) = @_;
4011	2				4	return 'do { my @arr = @$result; my %seen; !grep { $seen{$_}++ } @arr }';
4012						},
4013						applicable_to => ['arrayref'],
4014						},
4015
4016						preserves_keys => {
4017						description => 'Hash has same keys as input',
4018						code_template => sub {
4019	2			2	236	my ($function, $call_code, $input_vars) = @_;
4020	2				2	my $first_var = $input_vars->[0];
4021	2				5	return 'do { my @in = sort keys %{$' . $first_var . '}; ' .
4022						'my @out = sort keys %$result; ' .
4023						'join(",", @in) eq join(",", @out) }';
4024						},
4025	28			28	28613	applicable_to => ['hashref'],
4026						},
4027						};
4028						}
4029
4030						# --------------------------------------------------
4031						# _schema_to_lectrotest_generator
4032						#
4033						# Purpose: Convert a single schema field spec
4034						# hashref into a LectroTest generator
4035						# declaration string of the form
4036						# '$field <- Generator(...)'.
4037						# Used to build the ##[ ... ]## generator
4038						# block inside a Property definition.
4039						#
4040						# Entry: $field_name - the parameter name as it
4041						# will appear in the
4042						# generated test code.
4043						# $spec - hashref containing at
4044						# minimum a 'type' key.
4045						# May also contain 'min',
4046						# 'max', 'semantic', and
4047						# 'matches' keys depending
4048						# on type.
4049						#
4050						# Exit: Returns a string of the form
4051						# '$field <- Generator(...)' on success.
4052						# Returns undef if the spec is not a
4053						# hashref or if range constraints are
4054						# invalid (min >= max for numeric types).
4055						# Returns a String generator with a carp
4056						# warning for unknown types.
4057						#
4058						# Side effects: Carps on unknown semantic types,
4059						# invalid numeric ranges, and unknown
4060						# field types.
4061						#
4062						# Notes: Semantic generators are checked first
4063						# for string fields and take precedence
4064						# over the regular string generator.
4065						# The $input_spec parameter in the type-
4066						# detection helpers is reserved for future
4067						# use and is currently unused.
4068						# --------------------------------------------------
4069						sub _schema_to_lectrotest_generator {
4070	53			53	34428	my ($field_name, $spec) = @_;
4071
4072						# Guard: must be a hashref to dereference safely
4073	53	100	100		148	return unless defined($spec) && ref($spec) eq 'HASH';
4074
4075						# Default to string when no type is declared
4076	50		33		66	my $type = $spec->{'type'} \|\| $DEFAULT_FIELD_TYPE;
4077
4078						# --------------------------------------------------
4079						# Semantic generators take precedence for string
4080						# fields â€” they produce realistic domain-specific
4081						# values rather than random character sequences
4082						# --------------------------------------------------
4083	50	100	100		83	if($type eq 'string' && defined($spec->{'semantic'})) {
4084	1				2	my $semantic_type = $spec->{'semantic'};
4085	1				2	my $generators = _get_semantic_generators();
4086
4087	1	50			3	if(exists($generators->{$semantic_type})) {
4088	1				1	my $gen_code = $generators->{$semantic_type}{'code'};
4089
4090						# Compress the multi-line generator code into a
4091						# single line for embedding in the ##[ ]## block
4092	1				3	$gen_code =~ s/^\s+//;
4093	1				8	$gen_code =~ s/\s+$//;
4094	1				6	$gen_code =~ s/\n\s+/ /g;
4095
4096	1				5	return "$field_name <- $gen_code";
4097						} else {
4098	0				0	carp "Unknown semantic type '$semantic_type', " .
4099						"falling back to regular string generator";
4100						# Fall through to regular string generation below
4101						}
4102						}
4103
4104						# --------------------------------------------------
4105						# Integer generator
4106						# --------------------------------------------------
4107	49	100			51	if($type eq 'integer') {
4108	10				12	my $min = $spec->{'min'};
4109	10				12	my $max = $spec->{'max'};
4110
4111	10	100 100 100	100		32	if(!defined($min) && !defined($max)) {
4112						# Unconstrained â€” use LectroTest's built-in Int
4113	4				10	return "$field_name <- Int";
4114						} elsif(!defined($min)) {
4115						# Only max defined â€” generate 0 to max
4116	1				3	return "$field_name <- Int(sized => sub { int(rand($max + 1)) })";
4117						} elsif(!defined($max)) {
4118						# Only min defined â€” generate min to min + range
4119	1				7	return "$field_name <- Int(sized => sub { $min + int(rand($DEFAULT_GENERATOR_RANGE)) })";
4120						} else {
4121						# Both defined â€” generate within [min, max]
4122	4				5	my $range = $max - $min;
4123	4				11	return "$field_name <- Int(sized => sub { $min + int(rand($range + 1)) })";
4124						}
4125						}
4126
4127						# --------------------------------------------------
4128						# Float / number generator
4129						# --------------------------------------------------
4130	39	100	100		80	if($type eq 'number' \|\| $type eq 'float') {
4131	21				21	my $min = $spec->{'min'};
4132	21				20	my $max = $spec->{'max'};
4133
4134	21	100 100 100	100		68	if(!defined($min) && !defined($max)) {
4135						# Unconstrained â€” symmetric range around zero
4136	3				12	return "$field_name <- Float(sized => sub { rand($DEFAULT_GENERATOR_RANGE) - $DEFAULT_GENERATOR_RANGE / 2 })";
4137
4138						} elsif(!defined($min)) {
4139						# Only max defined â€” choose range based on sign of max
4140	7	100 100			14	if($max == $ZERO_BOUNDARY) {
4141						# max=0: negative numbers only
4142	5				29	return "$field_name <- Float(sized => sub { -rand($DEFAULT_GENERATOR_RANGE) })";
4143						} elsif($max > $ZERO_BOUNDARY) {
4144						# Positive max: generate 0 to max
4145	1				6	return "$field_name <- Float(sized => sub { rand($max) })";
4146						} else {
4147						# Negative max: generate from (max - range) to max
4148	1				6	return "$field_name <- Float(sized => sub { ($max - $DEFAULT_GENERATOR_RANGE) + rand($DEFAULT_GENERATOR_RANGE + $max) })";
4149						}
4150
4151						} elsif(!defined($max)) {
4152						# Only min defined â€” choose range based on sign of min
4153	6	100 100			8	if($min == $ZERO_BOUNDARY) {
4154						# min=0: positive numbers only
4155	4				12	return "$field_name <- Float(sized => sub { rand($DEFAULT_GENERATOR_RANGE) })";
4156						} elsif($min > $ZERO_BOUNDARY) {
4157						# Positive min: generate min to min + range
4158	1				6	return "$field_name <- Float(sized => sub { $min + rand($DEFAULT_GENERATOR_RANGE) })";
4159						} else {
4160						# Negative min: generate from min to min + range
4161	1				6	return "$field_name <- Float(sized => sub { $min + rand(-$min + $DEFAULT_GENERATOR_RANGE) })";
4162						}
4163
4164						} else {
4165						# Both min and max defined â€” validate then generate
4166	5				5	my $range = $max - $min;
4167	5	100			10	if($range <= $ZERO_BOUNDARY) {
4168	4				42	carp "Invalid range for '$field_name': min=$min, max=$max";
4169						# Return undef rather than emitting a degenerate
4170						# generator that would silently produce wrong values
4171	4				454	return;
4172						}
4173	1				5	return "$field_name <- Float(sized => sub { $min + rand($range) })";
4174						}
4175						}
4176
4177						# --------------------------------------------------
4178						# String generator
4179						# --------------------------------------------------
4180	18	100			41	if($type eq 'string') {
4181	10		100		20	my $min_len = $spec->{'min'} // 0;
4182	10		67		29	my $max_len = $spec->{'max'} // $DEFAULT_MAX_STRING_LEN;
4183
4184						# If a regex pattern is declared, delegate to
4185						# Data::Random::String::Matches for pattern-aware generation
4186	10	100			42	if(defined($spec->{'matches'})) {
4187	6				5	my $pattern = $spec->{'matches'};
4188
4189						# Compile the pattern safely rather than splicing the raw
4190						# string into qr/$pattern/ â€” the raw form lets a pattern
4191						# containing an unescaped '/' break out of the qr//
4192						# delimiter and inject arbitrary Perl into the generated
4193						# test. regexp_pattern() decomposes the already-compiled
4194						# Regexp object back into pattern text that is guaranteed
4195						# to be a self-contained regex body, safe to re-embed.
4196	6 3	100			13 48	my $compiled = ref($pattern) eq 'Regexp' ? $pattern : eval { qr/$pattern/ };
4197	6	50	33		19	if($@ \|\| !defined($compiled)) {
4198	0				0	carp "Invalid matches pattern '$pattern' for field '$field_name': $@";
4199	0				0	return "$field_name <- String(length => [$min_len, $max_len])";
4200						}
4201	6				17	my ($pat, $mods) = regexp_pattern($compiled);
4202	6		50		13	my $safe_re = "qr{$pat}" . ($mods // '');
4203
4204	6	100 100			14	if(defined($spec->{'max'})) {
4205	1				2	return "$field_name <- Gen { Data::Random::String::Matches->create_random_string({ regex => $safe_re, length => $spec->{'max'} }) }";
4206						} elsif(defined($spec->{'min'})) {
4207	1				3	return "$field_name <- Gen { Data::Random::String::Matches->create_random_string({ regex => $safe_re, length => $spec->{'min'} }) }";
4208						} else {
4209	4				12	return "$field_name <- Gen { Data::Random::String::Matches->create_random_string({ regex => $safe_re }) }";
4210						}
4211						}
4212
4213	4				9	return "$field_name <- String(length => [$min_len, $max_len])";
4214						}
4215
4216						# --------------------------------------------------
4217						# Boolean generator
4218						# --------------------------------------------------
4219	8	100			11	if($type eq 'boolean') {
4220	2				4	return "$field_name <- Bool";
4221						}
4222
4223						# --------------------------------------------------
4224						# Arrayref generator
4225						# --------------------------------------------------
4226	6	100			6	if($type eq 'arrayref') {
4227	2		50		7	my $min_size = $spec->{'min'} // 0;
4228	2		33		7	my $max_size = $spec->{'max'} // $DEFAULT_MAX_COLLECTION_SIZE;
4229	2				12	return "$field_name <- List(Int, length => [$min_size, $max_size])";
4230						}
4231
4232						# --------------------------------------------------
4233						# Hashref generator
4234						# LectroTest has no built-in Hash generator so we
4235						# use Elements over a pre-built list of hashrefs
4236						# --------------------------------------------------
4237	4	100			6	if($type eq 'hashref') {
4238	3		100		8	my $min_keys = $spec->{'min'} // 0;
4239	3		67		8	my $max_keys = $spec->{'max'} // $DEFAULT_MAX_COLLECTION_SIZE;
4240	3				11	return "$field_name <- Elements(map { my \%h; for (1..\$_) { \$h{'key'.\$_} = \$_ }; \\\%h } $min_keys..$max_keys)";
4241						}
4242
4243						# --------------------------------------------------
4244						# Unknown type â€” fall back to String with a warning
4245						# --------------------------------------------------
4246	1				12	carp "Unknown type '$type' for '$field_name' LectroTest generator, using String";
4247	1				271	return "$field_name <- String";
4248						}
4249
4250						# --------------------------------------------------
4251						# _is_numeric_transform
4252						#
4253						# Determine whether a transform's output
4254						# spec declares a numeric type, indicating
4255						# that numeric range properties should be
4256						# generated for it.
4257						#
4258						# Entry: $input_spec - the transform's input
4259						# spec hashref. Currently
4260						# unused; reserved for
4261						# future input-type checks.
4262						# $output_spec - the transform's output
4263						# spec hashref.
4264						#
4265						# Exit: Returns 1 if the output type is one of
4266						# 'number', 'integer', or 'float'.
4267						# Returns 0 otherwise.
4268						# --------------------------------------------------
4269						sub _is_numeric_transform {
4270	37			37	3915	my ($input_spec, $output_spec) = @_;
4271
4272						# $input_spec is currently unused â€” reserved for future
4273						# input-side type checking when detecting mixed transforms
4274	37		100 100		71	my $out_type = ($output_spec // {})->{'type'} // '';
4275
4276	37		100		94	return($out_type eq 'number' \|\| $out_type eq 'integer' \|\| $out_type eq 'float');
4277						}
4278
4279						# --------------------------------------------------
4280						# _is_string_transform
4281						#
4282						# Purpose: Determine whether a transform's output
4283						# spec declares a string type, indicating
4284						# that string length and pattern properties
4285						# should be generated for it.
4286						#
4287						# Entry: $input_spec - the transform's input
4288						# spec hashref. Currently
4289						# unused; reserved for
4290						# future input-type checks.
4291						# $output_spec - the transform's output
4292						# spec hashref.
4293						#
4294						# Exit: Returns 1 if the output type is 'string'.
4295						# Returns 0 otherwise.
4296						# --------------------------------------------------
4297						sub _is_string_transform {
4298	31			31	3095	my ($input_spec, $output_spec) = @_;
4299
4300						# $input_spec is currently unused â€” reserved for future
4301						# input-side type checking when detecting mixed transforms
4302	31		100 100		60	my $out_type = ($output_spec // {})->{'type'} // '';
4303
4304	31				41	return($out_type eq 'string');
4305						}
4306
4307						# --------------------------------------------------
4308						# _same_type
4309						#
4310						# Purpose: Determine whether the dominant type of
4311						# a transform's input and output specs
4312						# match, indicating that type-preservation
4313						# properties are meaningful.
4314						#
4315						# Entry: $input_spec - the transform's input
4316						# spec hashref, or a nested
4317						# multi-field hashref.
4318						# $output_spec - the transform's output
4319						# spec hashref.
4320						#
4321						# Exit: Returns 1 if the dominant input and
4322						# output types are identical strings.
4323						# Returns 0 otherwise.
4324						#
4325						# Notes: Uses _get_dominant_type for both sides.
4326						# For multi-field input specs, dominant
4327						# type is the type of the first field
4328						# encountered â€” this is a simplification.
4329						# TODO: extend to handle mixed-type inputs
4330						# by checking all fields, not just the
4331						# first one found.
4332						# --------------------------------------------------
4333						sub _same_type {
4334	31			31	4141	my ($input_spec, $output_spec) = @_;
4335
4336						# Guard: treat missing specs as untyped â€” two untyped
4337						# specs both default to $DEFAULT_FIELD_TYPE and would
4338						# compare equal, which is intentionally conservative
4339	31		100		43	my $in_type = _get_dominant_type($input_spec // {});
4340	31		100		47	my $out_type = _get_dominant_type($output_spec // {});
4341
4342	31				52	return($in_type eq $out_type);
4343						}
4344
4345						# --------------------------------------------------
4346						# _get_dominant_type
4347						#
4348						# Purpose: Extract the most representative type
4349						# string from a spec hashref. For flat
4350						# output specs this is simply the 'type'
4351						# key. For multi-field input specs it is
4352						# the type of the first sub-field found
4353						# that declares one.
4354						#
4355						# Entry: $spec - a spec hashref. May be a flat
4356						# output spec ({ type => '...' })
4357						# or a multi-field input spec
4358						# ({ field => { type => '...' } }).
4359						# May be undef or empty.
4360						#
4361						# Exit: Returns a type string. Returns
4362						# $DEFAULT_FIELD_TYPE ('string') if no
4363						# type can be determined.
4364						# --------------------------------------------------
4365						sub _get_dominant_type {
4366	93			93	6063	my $spec = $_[0];
4367
4368						# Guard: return default for undef or non-hash input
4369	93	100	67		159	return $DEFAULT_FIELD_TYPE
4370						unless defined($spec) && ref($spec) eq 'HASH';
4371
4372						# Flat spec â€” type declared directly
4373	91	100			97	return $spec->{'type'} if defined($spec->{'type'});
4374
4375						# Multi-field spec â€” return the type of the first
4376						# sub-field that declares one
4377	36 36				28 38	for my $field (keys %{$spec}) {
4378	31	100			44	next unless ref($spec->{$field}) eq 'HASH';
4379						return $spec->{$field}{'type'}
4380	29	100			55	if defined($spec->{$field}{'type'});
4381						}
4382
4383						# No type found anywhere â€” return the safe default
4384	8				13	return $DEFAULT_FIELD_TYPE;
4385						}
4386
4387						# --------------------------------------------------
4388						# _render_properties
4389						#
4390						# Purpose: Render an arrayref of property definition
4391						# hashrefs (as produced by
4392						# _generate_transform_properties) into a
4393						# string of Perl source code suitable for
4394						# embedding in a generated test file.
4395						# The output uses Test::LectroTest::Compat
4396						# to run each property as a holds() check.
4397						#
4398						# Entry: $properties - arrayref of property
4399						# hashrefs, each containing: name,
4400						# generator_spec, call_code,
4401						# property_checks, should_die,
4402						# should_warn, trials.
4403						# May be undef or an empty arrayref.
4404						#
4405						# Exit: Returns a string of Perl source code.
4406						# Returns an empty string if $properties
4407						# is undef, not an arrayref, or empty.
4408						#
4409						# Notes: The generated code uses 4-space
4410						# indentation deliberately â€” this is the
4411						# indentation style of the generated test
4412						# file, not of this module. Tabs are used
4413						# in this module's own source; spaces are
4414						# emitted into generated output for
4415						# readability of the produced test files.
4416						# --------------------------------------------------
4417						sub _render_properties {
4418	12			12	9232	my $properties = $_[0];
4419
4420						# Return empty string for absent or non-array input â€”
4421						# callers treat '' as no property block to emit
4422	12	100	100		54	return '' unless defined($properties) && ref($properties) eq 'ARRAY';
4423	9 9	100			8 17	return '' unless @{$properties};
4424
4425	7				7	my $code = "use_ok('Test::LectroTest::Compat');\n\n";
4426
4427	7 7				5 12	for my $prop (@{$properties}) {
4428						# Emit a labelled Property block for each transform property
4429	10				13	$code .= "# Transform property: $prop->{'name'}\n";
4430	10				13	$code .= "my \$$prop->{'name'} = Property {\n";
4431	10				12	$code .= " ##[ $prop->{'generator_spec'} ]##\n";
4432	10				8	$code .= " \n";
4433	10				10	$code .= " my \$result = eval { $prop->{'call_code'} };\n";
4434
4435	10	100			15	if($prop->{'should_die'}) {
4436						# For transforms that expect death, pass if the
4437						# eval caught an exception
4438	2				4	$code .= " my \$died = defined(\$\@) && \$\@;\n";
4439	2				2	$code .= " \$died;\n";
4440						} else {
4441						# For normal transforms, pass only if no exception
4442						# was thrown and all property checks hold
4443	8				6	$code .= " my \$error = \$\@;\n";
4444	8				8	$code .= " \n";
4445	8				7	$code .= " !\$error && (\n";
4446	8				12	$code .= " $prop->{'property_checks'}\n";
4447	8				11	$code .= " );\n";
4448						}
4449
4450	10				10	$code .= "}, name => '$prop->{'name'}', trials => $prop->{'trials'};\n\n";
4451	10				14	$code .= "holds(\$$prop->{'name'});\n";
4452						}
4453
4454	7				15	return $code;
4455						}
4456
4457						# --------------------------------------------------
4458						# _detect_transform_properties
4459						#
4460						# Purpose: Automatically derive a list of testable
4461						# LectroTest property hashrefs from a
4462						# transform's input and output specs.
4463						# Detects numeric range constraints, exact
4464						# value matches, string length constraints,
4465						# type preservation, and definedness.
4466						#
4467						# Entry: $transform_name - string name of the
4468						# transform, used for
4469						# heuristic matching
4470						# (e.g. 'positive').
4471						# $input_spec - the transform's input
4472						# hashref, or the string
4473						# 'undef'.
4474						# $output_spec - the transform's output
4475						# hashref, or undef if
4476						# absent.
4477						#
4478						# Exit: Returns a list of property hashrefs,
4479						# each containing 'name' and 'code' keys.
4480						# Returns an empty list if no properties
4481						# can be detected or if $input_spec is
4482						# undef or the string 'undef'.
4483						#
4484						# Notes: The 'positive' heuristic checks the
4485						# transform name case-insensitively against
4486						# $TRANSFORM_POSITIVE_PATTERN and adds a
4487						# non-negative constraint if matched.
4488						# This is intentionally a rough heuristic
4489						# rather than a precise semantic check.
4490						# --------------------------------------------------
4491						sub _detect_transform_properties {
4492	28			28	13109	my ($transform_name, $input_spec, $output_spec) = @_;
4493
4494	28				21	my @properties;
4495
4496						# Guard: skip undef input and the YAML scalar 'undef'
4497	28	100			32	return @properties unless defined($input_spec);
4498	26	100	67		40	return @properties if(!ref($input_spec) && $input_spec eq 'undef');
4499
4500						# Default output spec to empty hash so all key lookups
4501						# below are safe regardless of what the schema provides
4502	24		50		38	$output_spec //= {};
4503
4504						# --------------------------------------------------
4505						# Property 1: Output range constraints (numeric)
4506						# --------------------------------------------------
4507	24	100			30	if(_is_numeric_transform($input_spec, $output_spec)) {
4508	15	100			20	if(defined($output_spec->{'min'})) {
4509	11				13	my $min = $output_spec->{'min'};
4510	11				22	push @properties, {
4511						name => 'min_constraint',
4512						code => "defined(\$result) && looks_like_number(\$result) && \$result >= $min",
4513						};
4514						}
4515
4516	15	100			23	if(defined($output_spec->{'max'})) {
4517	2				21	my $max = $output_spec->{'max'};
4518	2				14	push @properties, {
4519						name => 'max_constraint',
4520						code => "defined(\$result) && looks_like_number(\$result) && \$result <= $max",
4521						};
4522						}
4523
4524						# Heuristic: transforms named 'positive' (case-insensitive)
4525						# imply a non-negative result constraint
4526	15	100			35	if($transform_name =~ /$TRANSFORM_POSITIVE_PATTERN/i) {
4527	6				30	push @properties, {
4528						name => 'non_negative',
4529						code => "defined(\$result) && looks_like_number(\$result) && \$result >= 0",
4530						};
4531						}
4532						}
4533
4534						# --------------------------------------------------
4535						# Property 2: Specific value output
4536						# --------------------------------------------------
4537	24	100			86	if(defined($output_spec->{'value'})) {
4538	2				4	my $expected = $output_spec->{'value'};
4539
4540						# Numeric refs use == for comparison; scalars use eq
4541						# via perl_quote to produce the correct quoted literal
4542	2	50			8	push @properties, {
4543						name => 'exact_value',
4544						code => ref($expected)
4545						? "\$result == $expected"
4546						: "\$result eq " . perl_quote($expected),
4547						};
4548						}
4549
4550						# --------------------------------------------------
4551						# Property 3: String length constraints
4552						# --------------------------------------------------
4553	24	100			31	if(_is_string_transform($input_spec, $output_spec)) {
4554	6	100			9	if(defined($output_spec->{'min'})) {
4555	2				5	push @properties, {
4556						name => 'min_length',
4557						code => "length(\$result) >= $output_spec->{'min'}",
4558						};
4559						}
4560
4561	6	50			7	if(defined($output_spec->{'max'})) {
4562	0				0	push @properties, {
4563						name => 'max_length',
4564						code => "length(\$result) <= $output_spec->{'max'}",
4565						};
4566						}
4567
4568	6	50			7	if(defined($output_spec->{'matches'})) {
4569	0				0	my $pattern = $output_spec->{'matches'};
4570
4571						# See the matching comment in _schema_to_lectrotest_generator â€”
4572						# compile first and re-embed via regexp_pattern() rather than
4573						# splicing the raw string into qr/$pattern/, which would let
4574						# an unescaped '/' break out of the delimiter.
4575	0 0	0			0 0	my $compiled = ref($pattern) eq 'Regexp' ? $pattern : eval { qr/$pattern/ };
4576	0	0	0		0	if($@ \|\| !defined($compiled)) {
4577	0				0	carp "Invalid matches pattern '$pattern' for transform '$transform_name': $@";
4578						} else {
4579	0				0	my ($pat, $mods) = regexp_pattern($compiled);
4580	0		0		0	my $safe_re = "qr{$pat}" . ($mods // '');
4581	0				0	push @properties, {
4582						name => 'pattern_match',
4583						code => "\$result =~ $safe_re",
4584						};
4585						}
4586						}
4587						}
4588
4589						# --------------------------------------------------
4590						# Property 4: Type preservation
4591						# --------------------------------------------------
4592	24	100			30	if(_same_type($input_spec, $output_spec)) {
4593	22				24	my $type = _get_dominant_type($output_spec);
4594
4595						# Only emit a numeric_type check for numeric types â€”
4596						# string and other types have no equivalent simple check
4597	22	100	75		51	if($type eq 'number' \|\| $type eq 'integer' \|\| $type eq 'float') {
4598	15				28	push @properties, {
4599						name => 'numeric_type',
4600						code => 'looks_like_number($result)',
4601						};
4602						}
4603						}
4604
4605						# --------------------------------------------------
4606						# Property 5: Definedness
4607						# --------------------------------------------------
4608						# Emit a defined() check for all transforms except those
4609						# whose output type is explicitly 'undef' â€” those are
4610						# expected to return nothing
4611	24	100	100		81	unless(($output_spec->{'type'} // '') eq 'undef') {
4612	22				31	push @properties, {
4613						name => 'defined',
4614						code => 'defined($result)',
4615						};
4616						}
4617
4618	24				37	return @properties;
4619						}
4620
4621						# --------------------------------------------------
4622						# _process_custom_properties
4623						#
4624						# Purpose: Process the 'properties' array from a
4625						# transform definition, resolving each
4626						# entry to either a named builtin property
4627						# (looked up from _get_builtin_properties)
4628						# or a custom property with inline code.
4629						#
4630						# Entry: $properties_spec - arrayref of property
4631						# definitions from the
4632						# schema. Each element
4633						# is either a string
4634						# (builtin name) or a
4635						# hashref with 'name'
4636						# and 'code' fields.
4637						# $function - name of the function
4638						# under test.
4639						# $module - module name, or undef
4640						# for builtins.
4641						# $input_spec - the transform's input
4642						# spec hashref.
4643						# $output_spec - the transform's output
4644						# spec hashref.
4645						# $new - defined if the function
4646						# is an OO method; value
4647						# is not used, only
4648						# presence is checked.
4649						#
4650						# Exit: Returns a list of property hashrefs,
4651						# each containing 'name', 'code', and
4652						# 'description' keys.
4653						# Invalid or unrecognised entries are
4654						# skipped with a carp warning.
4655						#
4656						# Side effects: Carps on unrecognised builtin names,
4657						# missing code fields, and invalid
4658						# property definition types.
4659						#
4660						# Notes: The sixth argument is $new (the OO
4661						# constructor signal), not the full schema
4662						# hashref. It is used only to determine
4663						# whether to emit OO-style call code for
4664						# builtin property templates.
4665						# --------------------------------------------------
4666						sub _process_custom_properties {
4667	7			7	9909	my ($properties_spec, $function, $module, $input_spec, $output_spec, $new) = @_;
4668
4669	7				7	my @properties;
4670	7				7	my $builtin_properties = _get_builtin_properties();
4671
4672	7 7				5 6	for my $prop_def (@{$properties_spec}) {
4673	6				7	my $prop_name;
4674						my $prop_code;
4675	6				0	my $prop_desc;
4676
4677	6	100 100			9	if(!ref($prop_def)) {
4678						# Plain string â€” look up as a named builtin property
4679	2				3	$prop_name = $prop_def;
4680
4681	2	100			11	unless(exists($builtin_properties->{$prop_name})) {
4682	1				11	carp "Unknown built-in property '$prop_name', skipping";
4683	1				114	next;
4684						}
4685
4686	1				1	my $builtin = $builtin_properties->{$prop_name};
4687
4688						# Build the argument list, respecting positional order
4689	1 1				1 3	my @var_names = sort keys %{$input_spec};
4690	1				1	my @args;
4691	1	50			2	if(_has_positions($input_spec)) {
4692	1 0				2 0	my @sorted = sort { $input_spec->{$a}{'position'} <=> $input_spec->{$b}{'position'} } @var_names;
4693	1 1				2 2	@args = map { "\$$_" } @sorted;
4694						} else {
4695	0 0				0 0	@args = map { "\$$_" } @var_names;
4696						}
4697
4698						# Build the call expression for the builtin template.
4699						# $new here is the raw OO signal from the caller â€”
4700						# defined means OO mode, undef means functional
4701	1				2	my $call_code;
4702	1	50 50	33 33		4	if($module && defined($new)) {
4703						# OO mode â€” fresh object per trial
4704	0				0	$call_code = "my \$obj = new_ok('$module');";
4705	0				0	$call_code .= "\$obj->$function";
4706						} elsif($module && $module ne $MODULE_BUILTIN) {
4707						# Functional mode with a named module
4708	0				0	$call_code = "$module\::$function";
4709						} else {
4710						# Builtin or unqualified function call
4711	1				1	$call_code = $function;
4712						}
4713	1				2	$call_code .= '(' . join(', ', @args) . ')';
4714
4715						# Instantiate the builtin's code template with the
4716						# call expression and input variable list
4717	1				2	$prop_code = $builtin->{'code_template'}->($function, $call_code, \@var_names);
4718	1				1	$prop_desc = $builtin->{'description'};
4719
4720						} elsif(ref($prop_def) eq 'HASH') {
4721						# Hashref â€” custom property with inline Perl code
4722	3		100		5	$prop_name = $prop_def->{'name'} \|\| 'custom_property';
4723	3				4	$prop_code = $prop_def->{'code'};
4724	3		67		6	$prop_desc = $prop_def->{'description'} \|\| "Custom property: $prop_name";
4725
4726	3	100			3	unless($prop_code) {
4727	1				5	carp "Custom property '$prop_name' missing 'code' field, skipping";
4728	1				88	next;
4729						}
4730
4731						# Sanity-check: code must contain at least a variable
4732						# reference or a word character to be meaningful
4733	2	50	33		6	unless($prop_code =~ /\$/ \|\| $prop_code =~ /\w+/) {
4734	0				0	carp "Custom property '$prop_name' code looks invalid: $prop_code";
4735	0				0	next;
4736						}
4737
4738						} else {
4739						# Neither string nor hashref â€” unrecognised definition type
4740	1				2	carp 'Invalid property definition: ', render_fallback($prop_def);
4741	1				82	next;
4742						}
4743
4744	3				6	push @properties, {
4745						name => $prop_name,
4746						code => $prop_code,
4747						description => $prop_desc,
4748						};
4749						}
4750
4751	7				71	return @properties;
4752						}
4753
4754 - 4831						=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
4832
4833						1;