File Coverage

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

linestmtbrancondsubtimecode
1package 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
7
13
13
526430
17
use 5.036;
8
9
13
13
13
23
8
112
use strict;
10
13
13
13
22
6
228
use warnings;
11
13
13
13
2144
86577
24
use autodie qw(:all);
12
13
13
13
13
102005
1242
31
use utf8;
14binmode STDOUT, ':utf8';
15binmode STDERR, ':utf8';
16
17
13
13
13
2386
6376
31
use open qw(:std :encoding(UTF-8));
18
19
13
13
13
84432
19
227
use App::Test::Generator::Template;
20
13
13
13
32
8
314
use Carp qw(carp croak);
21
13
13
13
2653
330240
179
use Config::Abstraction 0.36;
22
13
13
13
1903
23222
337
use Data::Dumper;
23
13
13
13
27
7
185
use Data::Section::Simple;
24
13
13
13
17
11
293
use File::Basename qw(basename);
25
13
13
13
22
7
111
use File::Spec;
26
13
13
13
2581
109747
375
use Module::Load::Conditional qw(check_install can_load);
27
13
13
13
28
10
162
use Params::Get;
28
13
13
13
17
9
154
use Params::Validate::Strict;
29
13
13
13
20
8
172
use Scalar::Util qw(looks_like_number);
30
13
13
13
33
9
714
use re 'regexp_pattern';
31
13
13
13
2650
94580
213
use Template;
32
13
13
13
1634
12570
334
use YAML::XS qw(LoadFile);
33
34
13
13
13
32
14
337
use Exporter 'import';
35
36our @EXPORT_OK = qw(generate);
37
38our $VERSION = '0.27';
39
40use constant {
41
13
432
        DEFAULT_ITERATIONS => 50,
42        DEFAULT_PROPERTY_TRIALS => 1000
43
13
13
31
11
};
44
45
13
13
13
35
12
66904
use constant CONFIG_TYPES => ('test_nuls', 'test_undef', 'test_empty', 'test_non_ascii', 'dedup', 'properties', 'close_stdin');
46
47 - 1228
=head1 NAME

App::Test::Generator - Generate fuzz and corpus-driven test harnesses from test schemas

=head1 VERSION

Version 0.27

=head1 SYNOPSIS

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/add.yml

  # Attempt to create a formal definition from a routine package, then run tests against that formal definition
  # This is the holy grail of automatic test generation, just by looking at the source code
  extract-schemas bin/extract-schemas lib/Sample/Module.pm && fuzz-harness-generator -r schemas/greet.yaml

From Perl:

  use App::Test::Generator qw(generate);

  # Generate to STDOUT
  App::Test::Generator::generate("t/conf/add.yml");

  # Generate directly to a file
  App::Test::Generator::generate('t/conf/add.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 => 'Foo.pm',
    output_dir => $dir
  );
  my $schemas = $extractor->extract_all();
  foreach my $schema(keys %{$schemas}) {
    my $tempfile = '/var/tmp/foo.t';    # Use File::Temp in real life
    App::Test::Generator->generate(
      schema => $schemas->{$schema},
      output_file => $tempfile,
    );
    system("$^X -I$dir $tempfile");
    unlink $tempfile;
  }

=encoding utf8

=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 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 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.

=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)

=back

All values default to C<true>.

=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 50).

=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, 2**31-1, -(2**31), 2**63-1, -(2**63) ]

=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: 50

=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@v5

        - name: Set up Perl
          uses: shogo82148/actions-setup-perl@v1
          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 50 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 L<Test::LectroTest> to be installed:

  cpanm Test::LectroTest

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

=head1 METHODS

=head2 generate

  generate($schema_file, $test_file)

Takes a schema file and produces a test file (or STDOUT).

=cut
1229
1230sub generate
1231{
1232
25
341497
        if($_[0] && ($_[0] eq __PACKAGE__)) {
1233
0
0
                shift;
1234        }
1235
1236
25
22
        my $args = $_[0];
1237
1238
25
41
        my ($schema_file, $test_file, $schema);
1239        # Globals loaded from the user's conf (all optional except function maybe)
1240
25
0
        my (%config, $module, $function, $new, $yaml_cases);
1241
25
0
        my ($seed, $iterations);
1242
1243
25
48
        if(ref($args) || defined($_[2])) {
1244                # Modern API
1245
0
0
                my $params = Params::Validate::Strict::validate_strict({
1246                        args => Params::Get::get_params(undef, \@_),
1247                        schema => {
1248                                input_file => { type => 'string', optional => 1 },
1249                                output_file => { type => 'string', optional => 1 },
1250                                schema => { type => 'hashref', optional => 1 },
1251                                quiet => { type => 'boolean', optional => 1 }, # Not yet used
1252                        }
1253                });
1254
0
0
                if($params->{'input_file'}) {
1255
0
0
                        $schema_file = $params->{'input_file'};
1256                } elsif($params->{'schema'}) {
1257
0
0
                        $schema = $params->{'schema'};
1258                } else {
1259
0
0
                        croak(__PACKAGE__, ': Usage: generate(input_file|schema [, output_file]');
1260                }
1261
0
0
                $test_file = $params->{'output_file'};
1262        } else {
1263                # Legacy API
1264
25
24
                ($schema_file, $test_file) = ($_[0], $_[1]);
1265
25
23
                if(defined($schema_file)) {
1266
24
27
                        $schema = _load_schema($schema_file);
1267
23
191
                        if(!defined($schema)) {
1268
0
0
                                croak "Failed to load schema from $schema_file";
1269                        }
1270                } else {
1271
1
6
                        croak 'Usage: generate(schema_file [, outfile])';
1272                }
1273        }
1274
1275        # Parse the schema file and load into our structures
1276
23
23
16
25
        my %input = %{_load_schema_section($schema, 'input', $schema_file)};
1277
22
22
15
18
        my %output = %{_load_schema_section($schema, 'output', $schema_file)};
1278
21
21
17
16
        my %transforms = %{_load_schema_section($schema, 'transforms', $schema_file)};
1279
1280
20
2
24
2
        my %cases = %{$schema->{cases}} if(exists($schema->{cases}));
1281
20
0
22
0
        my %edge_cases = %{$schema->{edge_cases}} if(exists($schema->{edge_cases}));
1282
20
0
20
0
        my %type_edge_cases = %{$schema->{type_edge_cases}} if(exists($schema->{type_edge_cases}));
1283
1284
20
38
        $module = $schema->{module} if(exists($schema->{module}) && length($schema->{module}));
1285
20
24
        $function = $schema->{function} if(exists($schema->{function}));
1286
20
19
        if(exists($schema->{new})) {
1287
2
3
                $new = defined($schema->{'new'}) ? $schema->{new} : '_UNDEF';
1288        }
1289
20
19
        $yaml_cases = $schema->{yaml_cases} if(exists($schema->{yaml_cases}));
1290
20
19
        $seed = $schema->{seed} if(exists($schema->{seed}));
1291
20
21
        $iterations = $schema->{iterations} if(exists($schema->{iterations}));
1292
1293
20
2
25
2
        my @edge_case_array = @{$schema->{edge_case_array}} if(exists($schema->{edge_case_array}));
1294
20
29
        _validate_config($schema);
1295
1296
17
5
15
10
        %config = %{$schema->{config}} if(exists($schema->{config}));
1297
1298
17
25
        _normalize_config(\%config);
1299
1300        # Guess module name from config file if not set
1301
17
29
        if(!$module) {
1302
0
0
                if($schema_file) {
1303
0
0
                        ($module = basename($schema_file)) =~ s/\.(conf|pl|pm|yml|yaml)$//;
1304
0
0
                        $module =~ s/-/::/g;
1305                }
1306        } elsif($module eq 'builtin') {
1307
6
4
                undef $module;
1308        }
1309
1310
17
56
        if($module && length($module) && ($module ne 'builtin')) {
1311
11
12
                _validate_module($module, $schema_file);
1312        }
1313
1314        # sensible defaults
1315
17
20
        $function ||= 'run';
1316
17
30
        $iterations ||= DEFAULT_ITERATIONS;              # default fuzz runs if not specified
1317
17
18
        $seed = undef if defined $seed && $seed eq '';  # treat empty as undef
1318
1319        # --- YAML corpus support (yaml_cases is filename string) ---
1320
17
13
        my %yaml_corpus_data;
1321
17
15
        if (defined $yaml_cases) {
1322
4
37
                croak("$yaml_cases: $!") if(!-f $yaml_cases);
1323
1324
3
7
                my $yaml_data = LoadFile(Encode::decode('utf8', $yaml_cases));
1325
3
157
                if ($yaml_data && ref($yaml_data) eq 'HASH') {
1326                        # Validate that the corpus inputs are arrayrefs
1327                        # e.g: "FooBar":      ["foo_bar"]
1328
3
1
                        my $valid_input = 1;
1329
3
3
2
6
                        for my $expected (keys %{$yaml_data}) {
1330
5
5
                                my $outputs = $yaml_data->{$expected};
1331
5
9
                                unless($outputs && (ref $outputs eq 'ARRAY')) {
1332
2
11
                                        carp("$yaml_cases: $expected does not point to an array ref, ignoring");
1333
2
171
                                        $valid_input = 0;
1334                                }
1335                        }
1336
1337
3
7
                        %yaml_corpus_data = %$yaml_data if($valid_input);
1338                }
1339        }
1340
1341        # Merge Perl %cases and YAML corpus safely
1342        # my %all_cases = (%cases, %yaml_corpus_data);
1343
16
17
        my %all_cases = (%yaml_corpus_data, %cases);
1344
16
16
        for my $k (keys %yaml_corpus_data) {
1345
3
7
                if (exists $cases{$k} && ref($cases{$k}) eq 'ARRAY' && ref($yaml_corpus_data{$k}) eq 'ARRAY') {
1346
1
1
1
1
1
1
                        $all_cases{$k} = [ @{$yaml_corpus_data{$k}}, @{$cases{$k}} ];
1347                }
1348        }
1349
1350
16
24
        if(my $hints = delete $schema->{_yamltest_hints}) {
1351
0
0
                if(my $boundaries = $hints->{boundary_values}) {
1352
0
0
0
0
                        push @edge_case_array, @{$boundaries};
1353                }
1354
0
0
                if(my $invalid = $hints->{invalid}) {
1355
0
0
                        carp('TODO: handle yamltest_hints->invalid');
1356                }
1357        }
1358
1359        # If the schema says the type is numeric, normalize
1360
16
18
        if ($schema->{type} && $schema->{type} =~ /^(integer|number|float)$/) {
1361
0
0
                for (@edge_case_array) {
1362
0
0
                        next unless defined $_;
1363
0
0
                        $_ += 0 if Scalar::Util::looks_like_number($_);
1364                }
1365        }
1366
1367        # Dedup the edge cases
1368
16
11
        my %seen;
1369        @edge_case_array = grep {
1370
16
6
11
16
                my $key = defined($_) ? (Scalar::Util::looks_like_number($_) ? "N:$_" : "S:$_") : 'U';
1371
6
6
                !$seen{$key}++;
1372        } @edge_case_array;
1373
1374        # Sort the edge cases to keep it consitent across runs
1375        @edge_case_array = sort {
1376
16
6
24
5
                return -1 if !defined $a;
1377
6
6
                return 1 if !defined $b;
1378
1379
6
4
                my $na = Scalar::Util::looks_like_number($a);
1380
6
5
                my $nb = Scalar::Util::looks_like_number($b);
1381
1382
6
6
                return $a <=> $b if $na && $nb;
1383
6
6
                return -1 if $na;
1384
6
4
                return 1 if $nb;
1385
6
7
                return $a cmp $b;
1386        } @edge_case_array;
1387
1388        # $self->_log(
1389                # 'EDGE CASES: ' . join(', ',
1390                        # map { defined($_) ? $_ : 'undef' } @edge_case_array
1391                # )
1392        # );
1393
1394        # render edge case maps for inclusion in the .t
1395
16
17
        my $edge_cases_code = render_arrayref_map(\%edge_cases);
1396
16
19
        my $type_edge_cases_code = render_arrayref_map(\%type_edge_cases);
1397
1398
16
11
        my $edge_case_array_code = '';
1399
16
14
        if(scalar(@edge_case_array)) {
1400
2
6
2
5
                $edge_case_array_code = join(', ', map { q_wrap($_) } @edge_case_array);
1401        }
1402
1403        # Render configuration - all the values are integers for now, if that changes, wrap the $config{$key} in single quotes
1404
16
12
        my $config_code = '';
1405
16
39
        foreach my $key (sort keys %config) {
1406                # Skip nested structures like 'properties' - they're used during
1407                # generation but don't need to be in the generated test
1408
112
83
                if(ref($config{$key}) eq 'HASH') {
1409
16
12
                        next;
1410                }
1411
96
111
                if((!defined($config{$key})) || !$config{$key}) {
1412                        # YAML will strip the word 'false'
1413                        # e.g. in 'test_undef: false'
1414
15
15
                        $config_code .= "'$key' => 0,\n";
1415                } else {
1416
81
84
                        $config_code .= "'$key' => $config{$key},\n";
1417                }
1418        }
1419
1420        # Render input/output
1421
16
15
        my $input_code = '';
1422
16
36
        if(((scalar keys %input) == 1) && exists($input{'type'}) && !ref($input{'type'})) {
1423                # %input = ( type => 'string' );
1424
4
3
                foreach my $key (sort keys %input) {
1425
4
5
                        $input_code .= "'$key' => '$input{$key}',\n";
1426                }
1427        } else {
1428                # %input = ( str => { type => 'string' } );
1429
12
14
                $input_code = render_hash(\%input);
1430        }
1431
16
25
        if(defined(my $re = $output{'matches'})) {
1432
0
0
                if(ref($re) ne 'Regexp') {
1433
0
0
                        $re = qr/$re/;
1434
0
0
                        $output{'matches'} = $re;
1435                }
1436        }
1437
16
13
        my $output_code = render_args_hash(\%output);
1438
16
21
        my $new_code = ($new && (ref $new eq 'HASH')) ? render_args_hash($new) : '';
1439
1440
16
9
        my $transforms_code;
1441
16
15
        if(keys %transforms) {
1442
4
4
                foreach my $transform(keys %transforms) {
1443
8
12
                        my $properties = render_fallback($transforms{$transform}->{'properties'});
1444
1445
8
12
                        if($transforms_code) {
1446
4
3
                                $transforms_code .= "},\n";
1447                        }
1448                        $transforms_code .= "$transform => {\n" .
1449                                "\t'input' => { " .
1450                                render_args_hash($transforms{$transform}->{'input'}) .
1451                                "\t}, 'output' => { " .
1452
8
11
                                render_args_hash($transforms{$transform}->{'output'}) .
1453                                "\t}, 'properties' => $properties\n" .
1454                                "\t,\n";
1455                }
1456
4
4
                $transforms_code .= "}\n";
1457        }
1458
1459
16
12
        my $transform_properties_code = '';
1460
16
7
        my $use_properties = 0;
1461
1462
16
22
        if (keys %transforms && ($config{properties}{enable} // 0)) {
1463
4
3
                $use_properties = 1;
1464
1465                # Generate property-based tests for transforms
1466
4
6
                my $properties = _generate_transform_properties(
1467                        \%transforms,
1468                        $function,
1469                        $module,
1470                        \%input,
1471                        \%config,
1472                        $new
1473                );
1474
1475                # Convert to code for template
1476
4
5
                $transform_properties_code = _render_properties($properties);
1477        }
1478
1479        # Setup / call code (always load module)
1480
16
19
        my $setup_code = ($module) ? "BEGIN { use_ok('$module') }" : '';
1481
16
10
        my $call_code;  # Code to call the function being test when used with named arguments
1482        my $position_code;      # Code to call the function being test when used with position arguments
1483
16
15
        my $has_positions = _has_positions(\%input);
1484
16
25
        if(defined($new)) {
1485                # keep use_ok regardless (user found earlier issue)
1486
2
2
                if($new_code eq '') {
1487
1
1
                        $setup_code .= "\nmy \$obj = new_ok('$module');";
1488                } else {
1489
1
1
                        $setup_code .= "\nmy \$obj = new_ok('$module' => [ { $new_code } ] );";
1490                }
1491
2
2
                if($has_positions) {
1492
0
0
                        $position_code = "(\$result = scalar(\@alist) == 1) ? \$obj->$function(\$alist[0]) : (scalar(\@alist) == 0) ? \$obj->$function() : \$obj->$function(\@alist);";
1493                } else {
1494
2
2
                        $call_code = "\$result = \$obj->$function(\$input);";
1495
2
2
                        if($output{'_returns_self'}) {
1496
0
0
                                $call_code .= "ok(defined(\$result)); ok(\$result eq \$obj, '$function returns self')";
1497                        }
1498                }
1499        } elsif(defined($module) && length($module)) {
1500
8
8
                if($function eq 'new') {
1501
0
0
                        if($has_positions) {
1502
0
0
                                $position_code = "(\$result = scalar(\@alist) == 1) ? ${module}\->$function(\$alist[0]) : (scalar(\@alist) == 0) ? ${module}\->$function() : ${module}\->$function(\@alist);";
1503                        } else {
1504
0
0
                                $call_code = "\$result = ${module}\->$function(\$input);";
1505                        }
1506                } else {
1507
8
5
                        if($has_positions) {
1508
0
0
                                $position_code = "(\$result = scalar(\@alist) == 1) ? ${module}::$function(\$alist[0]) : (scalar(\@alist) == 0) ? ${module}::$function() : ${module}::$function(\@alist);";
1509                        } else {
1510
8
9
                                $call_code = "\$result = ${module}::$function(\$input);";
1511                        }
1512                }
1513        } else {
1514
6
6
                if($has_positions) {
1515
4
6
                        $position_code = "\$result = $function(\@alist);";
1516                } else {
1517
2
2
                        $call_code = "\$result = $function(\$input);";
1518                }
1519        }
1520
1521        # Build static corpus code
1522
16
15
        my $corpus_code = '';
1523
16
31
        if (%all_cases) {
1524
2
2
                $corpus_code = "\n# --- Static Corpus Tests ---\n" .
1525                        "diag('Running " . scalar(keys %all_cases) . " corpus tests');\n";
1526
1527
2
3
                for my $expected (sort keys %all_cases) {
1528
5
5
                        my $inputs = $all_cases{$expected};
1529
5
5
                        next unless($inputs);
1530
1531
5
4
                        my $expected_str = perl_quote($expected);
1532
5
10
                        my $status = ((ref($inputs) eq 'HASH') && $inputs->{'_STATUS'}) // 'OK';
1533
5
6
                        if($expected_str eq "'_STATUS:DIES'") {
1534
0
0
                                $status = 'DIES';
1535                        } elsif($expected_str eq "'_STATUS:WARNS'") {
1536
0
0
                                $status = 'WARNS';
1537                        }
1538
1539
5
5
                        if(ref($inputs) eq 'HASH') {
1540
0
0
                                $inputs = $inputs->{'input'};
1541                        }
1542
5
3
                        my $input_str;
1543
5
4
                        if(ref($inputs) eq 'ARRAY') {
1544
5
8
5
3
5
5
                                $input_str = join(', ', map { perl_quote($_) } @{$inputs});
1545                        } elsif(ref($inputs) eq 'HASH') {
1546
0
0
                                $input_str = Dumper($inputs);
1547
0
0
                                $input_str =~ s/\$VAR1 =//;
1548
0
0
                                $input_str =~ s/;//;
1549
0
0
                                $input_str =~ s/=> 'undef'/=> undef/gms;
1550                        } else {
1551
0
0
                                $input_str = $inputs;
1552                        }
1553
5
6
                        if(($input_str eq 'undef') && (!$config{'test_undef'})) {
1554
0
0
                                carp('corpus case set to undef, yet test_undef is not set in config');
1555                        }
1556
5
4
                        if($new) {
1557
0
0
                                if($status eq 'DIES') {
1558                                        $corpus_code .= "dies_ok { \$obj->$function($input_str) } " .
1559
0
0
0
0
                                                        "'$function(" . join(', ', map { $_ // '' } @$inputs ) . ") dies';\n";
1560                                } elsif($status eq 'WARNS') {
1561                                        $corpus_code .= "warnings_exist { \$obj->$function($input_str) } qr/./, " .
1562
0
0
0
0
                                                        "'$function(" . join(', ', map { $_ // '' } @$inputs ) . ") warns';\n";
1563                                } else {
1564                                        my $desc = sprintf("$function(%s) returns %s",
1565
0
0
0
0
                                                perl_quote(join(', ', map { $_ // '' } @$inputs )),
1566                                                $expected_str
1567                                        );
1568
0
0
                                        if($output{'type'} eq 'boolean') {
1569
0
0
                                                if($expected_str eq '1') {
1570
0
0
                                                        $corpus_code .= "ok(\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
1571                                                } elsif($expected_str eq '0') {
1572
0
0
                                                        $corpus_code .= "ok(!\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
1573                                                } else {
1574
0
0
                                                        croak("Boolean is expected to return $expected_str");
1575                                                }
1576                                        } else {
1577
0
0
                                                $corpus_code .= "is(\$obj->$function($input_str), $expected_str, " . q_wrap($desc) . ");\n";
1578                                        }
1579                                }
1580                        } else {
1581
5
7
                                if($status eq 'DIES') {
1582
0
0
                                        if($module) {
1583
0
0
                                                $corpus_code .= "dies_ok { $module\::$function($input_str) } " .
1584                                                        "'Corpus $expected dies';\n";
1585                                        } else {
1586
0
0
                                                $corpus_code .= "dies_ok { ::$function($input_str) } " .
1587                                                        "'Corpus $expected dies';\n";
1588                                        }
1589                                } elsif($status eq 'WARNS') {
1590
0
0
                                        if($module) {
1591
0
0
                                                $corpus_code .= "warnings_exist { $module\::$function($input_str) } qr/./, " .
1592                                                        "'Corpus $expected warns';\n";
1593                                        } else {
1594
0
0
                                                $corpus_code .= "warnings_exist { ::$function($input_str) } qr/./, " .
1595                                                        "'Corpus $expected warns';\n";
1596                                        }
1597                                } else {
1598                                        my $desc = sprintf("$function(%s) returns %s",
1599
5
8
5
9
10
3
                                                perl_quote((ref $inputs eq 'ARRAY') ? (join(', ', map { $_ // '' } @{$inputs})) : $inputs),
1600                                                $expected_str
1601                                        );
1602
5
8
                                        if($output{'type'} eq 'boolean') {
1603
0
0
                                                if($expected_str eq '1') {
1604
0
0
                                                        $corpus_code .= "ok(\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
1605                                                } elsif($expected_str eq '0') {
1606
0
0
                                                        $corpus_code .= "ok(!\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
1607                                                } else {
1608
0
0
                                                        croak("Boolean is expected to return $expected_str");
1609                                                }
1610                                        } else {
1611
5
21
                                                $corpus_code .= "is(\$obj->$function($input_str), $expected_str, " . q_wrap($desc) . ");\n";
1612                                        }
1613                                }
1614                        }
1615                }
1616        }
1617
1618        # Prepare seed/iterations code fragment for the generated test
1619
16
12
        my $seed_code = '';
1620
16
13
        if (defined $seed) {
1621                # ensure integer-ish
1622
0
0
                $seed = int($seed);
1623
0
0
                $seed_code = "srand($seed);\n";
1624        }
1625
1626
16
20
        my $determinism_code = 'my $result2;' .
1627                'eval { $result2 = do { ' . (defined($position_code) ? $position_code : $call_code) . " }; };\n" .
1628                'is_deeply($result2, $result, "deterministic result for same input");' .
1629                "\n";
1630
1631        # Generate the test content
1632
16
56
        my $tt = Template->new({ ENCODING => 'utf8', TRIM => 1 });
1633
1634        # Read template from DATA handle
1635
16
63993
        my $template_package = __PACKAGE__ . '::Template';
1636
16
43
        my $template = $template_package->get_data_section('test.tt');
1637
1638        my $vars = {
1639                setup_code => $setup_code,
1640                edge_cases_code => $edge_cases_code,
1641                edge_case_array_code => $edge_case_array_code,
1642                type_edge_cases_code => $type_edge_cases_code,
1643                config_code => $config_code,
1644                seed_code => $seed_code,
1645                input_code => $input_code,
1646                output_code => $output_code,
1647                transforms_code => $transforms_code,
1648                corpus_code => $corpus_code,
1649                call_code => $call_code,
1650                position_code => $position_code,
1651                determinism_code => $determinism_code,
1652                function => $function,
1653                iterations_code => int($iterations),
1654                use_properties => $use_properties,
1655                transform_properties_code => $transform_properties_code,
1656
16
14009
                property_trials => $config{properties}{trials} // DEFAULT_PROPERTY_TRIALS,
1657                module => $module
1658        };
1659
1660
16
13
        my $test;
1661
16
28
        $tt->process($template, $vars, \$test) or croak($tt->error());
1662
1663
16
286280
        if ($test_file) {
1664
14
25
                open my $fh, '>:encoding(UTF-8)', $test_file or die "Cannot open $test_file: $!";
1665
14
9482
                print $fh "$test\n";
1666
14
34
                close $fh;
1667
14
2532
                if($module) {
1668
8
119
                        print "Generated $test_file for $module\::$function with fuzzing + corpus support\n";
1669                } else {
1670
6
73
                        print "Generated $test_file for $function with fuzzing + corpus support\n";
1671                }
1672        } else {
1673
2
559
                print "$test\n";
1674        }
1675}
1676
1677# --- Helpers for rendering data structures into Perl code for the generated test ---
1678
1679sub _load_schema {
1680
24
14
        my $schema_file = $_[0];
1681
1682
24
123
        if(!-r $schema_file) {
1683
1
98
                croak(__PACKAGE__, ": generate($schema_file): $!");
1684        }
1685
1686        # --- Load configuration safely (require so config can use 'our' variables) ---
1687        # FIXME:  would be better to use Config::Abstraction, since requiring the user's config could execute arbitrary code
1688        # my $abs = $schema_file;
1689        # $abs = "./$abs" unless $abs =~ m{^/};
1690        # require $abs;
1691
1692
23
80
        if(my $schema = Config::Abstraction->new(config_dirs => ['.', ''], config_file => $schema_file)) {
1693
23
25128
                if($schema = $schema->all()) {
1694
23
149
                        if(defined($schema->{'$module'}) || defined($schema->{'our $module'}) || !defined($schema->{'module'})) {
1695
0
0
                                croak("$schema_file: Loading perl files as configs is no longer supported");
1696                        }
1697
23
29
                        $schema->{'_source'} = $schema_file;
1698
23
71
                        return $schema;
1699                }
1700        }
1701}
1702
1703sub _load_schema_section
1704{
1705
66
55
        my($schema, $section, $schema_file) = @_;
1706
1707
66
64
        if(exists($schema->{$section})) {
1708
43
47
                if(ref($schema->{$section}) eq 'HASH') {
1709
39
65
                        return $schema->{$section};
1710                } elsif(defined($schema->{$section}) && ($schema->{$section} ne 'undef')) {
1711                        # carp(Dumper($schema));
1712
3
3
                        if(ref($schema->{$section}) && length($schema->{$section})) {
1713
0
0
                                croak("$schema_file: $section should be a hash, not ", ref($schema->{$section}));
1714                        } else {
1715
3
15
                                croak("$schema_file: $section should be a hash, not ", $schema->{$section});
1716                        }
1717                }
1718        }
1719
24
23
        return {};
1720}
1721
1722# Input validation for configuration
1723sub _validate_config {
1724
20
25
        my $config = $_[0];
1725
1726
20
19
        if((!defined($config->{'module'})) && (!defined($config->{'function'}))) {
1727                # Can't work out what should be tested
1728
0
0
                croak('At least one of function and module must be defined');
1729        }
1730
1731
20
22
        if((!defined($config->{'input'})) && (!defined($config->{'output'}))) {
1732                # Routine takes no input and no output, so there's nothing that would be gained using this software
1733
2
11
                croak('You must specify at least one of input and output');
1734        }
1735
18
34
        if(($config->{'input'}) && (ref($config->{input}) ne 'HASH')) {
1736
0
0
                if($config->{'input'} eq 'undef') {
1737
0
0
                        delete $config->{'input'};
1738                } else {
1739
0
0
                        croak('Invalid input specification')
1740                }
1741        }
1742
1743
18
18
        if($config->{input}) {
1744                # Validate types, constraints, etc.
1745
17
17
15
23
                for my $param (keys %{$config->{input}}) {
1746
17
18
                        if(!length($param)) {
1747
0
0
                                croak 'Empty input parameter name';
1748                        }
1749
17
22
                        my $spec = $config->{input}{$param};
1750
17
16
                        if(ref($spec)) {
1751
12
13
                                croak("Missing type for parameter '$param'") unless(defined $spec->{type});
1752
12
13
                                croak("Invalid type '$spec->{type}' for parameter '$param'") unless _valid_type($spec->{type});
1753                        } else {
1754
5
5
                                croak "Invalid type '$spec' for parameter '$param'" unless _valid_type($spec);
1755                        }
1756                }
1757
1758                # Check if using positional arguments
1759
16
14
                my $has_positions = 0;
1760
16
7
                my %positions;
1761
1762
16
16
14
14
                for my $param (keys %{$config->{input}}) {
1763
16
13
                        my $spec = $config->{input}{$param};
1764
16
30
                        if (ref($spec) eq 'HASH' && defined($spec->{position})) {
1765
4
3
                                $has_positions = 1;
1766
4
4
                                my $pos = $spec->{position};
1767
1768                                # Validate position is non-negative integer
1769
4
8
                                croak "Position for '$param' must be a non-negative integer" unless $pos =~ /^\d+$/;
1770
1771                                # Check for duplicate positions
1772
4
5
                                croak "Duplicate position $pos for parameters '$positions{$pos}' and '$param'" if exists $positions{$pos};
1773
1774
4
5
                                $positions{$pos} = $param;
1775                        }
1776                }
1777
1778                # If using positions, all params must have positions
1779
16
14
                if ($has_positions) {
1780
4
4
2
4
                        for my $param (keys %{$config->{input}}) {
1781
4
4
                                my $spec = $config->{input}{$param};
1782
4
14
                                unless (ref($spec) eq 'HASH' && defined($spec->{position})) {
1783
0
0
                                        croak "Parameter '$param' missing position (all params must have positions if any do)";
1784                                }
1785                        }
1786
1787                        # Check for gaps in positions (0, 1, 3 - missing 2)
1788
4
0
8
0
                        my @sorted = sort { $a <=> $b } keys %positions;
1789
4
5
                        for my $i (0..$#sorted) {
1790
4
8
                                if ($sorted[$i] != $i) {
1791
0
0
                                        carp "Warning: Position sequence has gaps (positions: @sorted)";
1792
0
0
                                        last;
1793                                }
1794                        }
1795                }
1796
1797                # Validate input types
1798
16
15
                my $semantic_generators = _get_semantic_generators();
1799
16
16
13
14
                for my $param (keys %{$config->{input}}) {
1800
16
12
                        my $spec = $config->{input}{$param};
1801
16
31
                        if(ref($spec) eq 'HASH') {
1802
11
25
                                if(defined($spec->{semantic})) {
1803
0
0
                                        my $semantic = $spec->{semantic};
1804
0
0
                                        unless (exists $semantic_generators->{$semantic}) {
1805
0
0
                                                carp "Warning: $config->{_source}: Unknown semantic type '$semantic' for parameter '$param'. Available types: ",
1806                                                        join(', ', sort keys %$semantic_generators);
1807                                        }
1808                                }
1809
11
14
                                if($spec->{'enum'} && $spec->{'memberof'}) {
1810
0
0
                                        croak "$param: has both enum and memberof";
1811                                }
1812
11
10
                                for my $type('enum', 'memberof') {
1813
22
54
                                        if(exists $spec->{$type}) {
1814
0
0
                                                croak "$type must be arrayref" unless(ref($spec->{$type}) eq 'ARRAY');
1815                                        }
1816                                }
1817                        }
1818                }
1819        }
1820
1821        # Validate custom properties in transforms
1822
17
31
        if (exists $config->{transforms} && ref($config->{transforms}) eq 'HASH') {
1823
4
5
                my $builtin_props = _get_builtin_properties();
1824
1825
4
4
4
6
                for my $transform_name (keys %{$config->{transforms}}) {
1826
8
8
                        my $transform = $config->{transforms}{$transform_name};
1827
1828
8
76
                        if (exists $transform->{properties}) {
1829
0
0
                                unless (ref($transform->{properties}) eq 'ARRAY') {
1830
0
0
                                        croak "Transform '$transform_name': properties must be an array";
1831                                }
1832
1833
0
0
0
0
                                for my $prop (@{$transform->{properties}}) {
1834
0
0
                                        if (!ref($prop)) {
1835                                                # Check if builtin exists
1836
0
0
                                                unless (exists $builtin_props->{$prop}) {
1837
0
0
                                                        carp "Transform '$transform_name': unknown built-in property '$prop'. Available: ",
1838                                                                join(', ', sort keys %$builtin_props);
1839                                                }
1840                                        }
1841                                        elsif (ref($prop) eq 'HASH') {
1842                                                # Validate custom property structure
1843
0
0
                                                unless ($prop->{name} && $prop->{code}) {
1844
0
0
                                                        croak "Transform '$transform_name': custom properties must have 'name' and 'code' fields";
1845                                                }
1846                                        }
1847                                        else {
1848
0
0
                                                croak "Transform '$transform_name': invalid property definition";
1849                                        }
1850                                }
1851                        }
1852                }
1853        }
1854
1855
17
20
        if(ref($config->{config}) eq 'HASH') {
1856                # Validate the config variables, checking that they are ones we know
1857
5
5
4
6
                foreach my $k (keys %{$config->{'config'}}) {
1858
20
140
18
99
                        if(!grep { $_ eq $k } (CONFIG_TYPES) ) {
1859
0
0
                                croak "unknown config setting $k";
1860                        }
1861                }
1862        }
1863}
1864
1865# Handle the various possible boolean settings for config values
1866# Note that the default for everything is true
1867sub _normalize_config
1868{
1869
17
11
        my $config = $_[0];
1870
1871
17
28
        foreach my $field (CONFIG_TYPES) {
1872
119
91
                next if($field eq 'properties');        # Not a boolean
1873
102
63
                if(exists($config->{$field})) {
1874
16
37
                        if(($config->{$field} eq 'false') || ($config->{$field} eq 'off') || ($config->{$field} eq 'no')) {
1875
15
15
                                $config->{$field} = 0;
1876                        } elsif(($config->{$field} eq 'true') || ($config->{$field} eq 'on') || ($config->{$field} eq 'yes')) {
1877
1
1
                                $config->{$field} = 1;
1878                        }
1879                } else {
1880
86
76
                        $config->{$field} = 1;
1881                }
1882        }
1883
1884
17
33
        $config->{properties} = { enable => 0 } unless ref $config->{properties} eq 'HASH';
1885}
1886
1887sub _valid_type
1888{
1889
26
1003
        my $type = $_[0];
1890
1891
26
28
        return 0 if(!defined($type));
1892
1893
26
80
25
74
        state %VALID = map { $_ => 1 } qw(
1894                string boolean integer number float hashref arrayref object int bool
1895        );
1896
26
42
        return $VALID{$type};
1897}
1898
1899sub _validate_module {
1900
11
11
        my ($module, $schema_file) = @_;
1901
1902
11
13
        return 1 unless $module;        # No module to validate (builtin functions)
1903
1904        # Check if the module can be found
1905
11
12
        my $mod_info = check_install(module => $module);
1906
1907
11
29723
        if($schema_file && !$mod_info) {
1908                # Module not found - this is just a warning, not an error
1909                # The module might not be installed on the generation machine
1910                # but could be on the test machine
1911
1
16
                carp("Warning: Module '$module' not found in \@INC during generation.");
1912
1
106
                carp("  Config file: $schema_file");
1913
1
80
                carp("  This is OK if the module will be available when tests run.");
1914
1
99
                carp('  If this is unexpected, check your module name and installation.');
1915
1
68
                return 0;       # Not found, but not fatal
1916        }
1917
1918        # Module was found
1919
10
21
        if($ENV{TEST_VERBOSE} || $ENV{GENERATOR_VERBOSE}) {
1920                print STDERR "Found module '$module' at: $mod_info->{file}\n",
1921
0
0
                        '  Version: ', ($mod_info->{version} || 'unknown'), "\n";
1922        }
1923
1924        # Optionally try to load it (disabled by default since it can have side effects)
1925
10
11
        if($ENV{GENERATOR_VALIDATE_LOAD}) {
1926
0
0
                my $loaded = can_load(modules => { $module => undef }, verbose => 0);
1927
1928
0
0
                if(!$loaded) {
1929
0
0
                        my $err = $Module::Load::Conditional::ERROR || 'unknown error';
1930
0
0
                        carp("Warning: Module '$module' found but failed to load: $err");
1931
0
0
                        carp('  This might indicate a broken installation or missing dependencies.');
1932
0
0
                        return 0;
1933                }
1934
1935
0
0
                if($ENV{TEST_VERBOSE} || $ENV{GENERATOR_VERBOSE}) {
1936
0
0
                        print STDERR "Successfully loaded module '$module'\n";
1937                }
1938        }
1939
1940
10
18
        return 1;
1941}
1942
1943sub perl_sq {
1944
106
58
        my $s = $_[0];
1945
1946
106
70
        return '' unless defined $s;
1947
1948
106
61
        $s =~ s/\\/\\\\/g;
1949
106
67
        $s =~ s/'/\\'/g;
1950
106
71
        $s =~ s/\n/\\n/g;
1951
106
61
        $s =~ s/\r/\\r/g;
1952
106
59
        $s =~ s/\t/\\t/g;
1953
106
57
        $s =~ s/\f/\\f/g;
1954        # $s =~ s/\b/\\b/g;
1955
106
73
        $s =~ s/\0/\\0/g;
1956
106
158
        return $s;
1957}
1958
1959sub perl_quote {
1960
131
84
        my $v = $_[0];
1961
131
100
        return 'undef' unless defined $v;
1962
131
89
        return '!!1' if $v eq 'true';
1963
131
78
        if(ref($v)) {
1964
9
12
                if(ref($v) eq 'ARRAY') {
1965
0
0
0
0
0
0
                        my @quoted_v = map { perl_quote($_) } @{$v};
1966
0
0
                        return '[ ' . join(', ', @quoted_v) . ' ]';
1967                }
1968
9
9
                if(ref($v) eq 'Regexp') {
1969
0
0
                        my ($pat, $mods) = regexp_pattern($v);
1970
1971
0
0
                        my $re = "qr{$pat}";
1972
0
0
                        $re .= $mods if $mods;
1973
0
0
                        return $re;
1974                }
1975                # Generic fallback
1976
9
8
                return render_fallback($v);
1977        }
1978
122
90
        $v =~ s/\\/\\\\/g;
1979        # return $v =~ /^-?\d+(\.\d+)?$/ ? $v : "'" . perl_sq($v) . "'";
1980
122
135
        return looks_like_number($v) ? $v : "'" . perl_sq($v) . "'";
1981}
1982
1983sub render_fallback
1984{
1985
17
14
        my $v = $_[0];
1986
1987
17
15
        local $Data::Dumper::Terse = 1;
1988
17
13
        local $Data::Dumper::Indent = 0;
1989
17
16
        my $s = Dumper($v);
1990
17
367
        chomp $s;
1991
17
26
        return $s;
1992}
1993
1994sub render_hash {
1995
12
10
        my $href = $_[0];
1996
12
27
        return '' unless $href && ref($href) eq 'HASH';
1997
12
13
        my @lines;
1998
12
13
        for my $k (sort keys %$href) {
1999
11
16
                my $def = $href->{$k} // {};
2000
11
41
                next unless ref $def eq 'HASH';
2001
10
7
                my @pairs;
2002
10
12
                for my $subk (sort keys %$def) {
2003
14
20
                        next unless defined $def->{$subk};
2004
14
25
                        if(ref($def->{$subk})) {
2005
0
0
                                unless((ref($def->{$subk}) eq 'ARRAY') || (ref($def->{$subk}) eq 'Regexp')) {
2006
0
0
                                        croak(__PACKAGE__, ": schema_file, $subk is a nested element, not yet supported (", ref($def->{$subk}), ')');
2007                                }
2008                        }
2009
14
38
                        if(($subk eq 'matches') || ($subk eq 'nomatch')) {
2010                                # push @pairs, "$subk => qr/$def->{$subk}/";
2011
0
0
                                push @pairs, "$subk => " . perl_quote(qr/$def->{$subk}/);
2012                        } else {
2013
14
25
                                push @pairs, "$subk => " . perl_quote($def->{$subk});
2014                        }
2015                }
2016
10
14
                push @lines, '      ' . perl_quote($k) . " => { " . join(", ", @pairs) . " }";
2017        }
2018
12
37
        return join(",\n", @lines);
2019}
2020
2021sub render_args_hash {
2022
33
22
        my $href = $_[0];
2023
33
54
        return '' unless $href && ref($href) eq 'HASH';
2024
33
44
35
32
        my @pairs = map { perl_quote($_) . ' => ' . perl_quote($href->{$_}) } sort keys %$href;
2025
33
57
        return join(', ', @pairs);
2026}
2027
2028sub render_arrayref_map {
2029
32
19
        my $href = $_[0];
2030
32
51
        return '()' unless $href && ref($href) eq 'HASH';
2031
32
22
        my @entries;
2032
32
26
        for my $k (sort keys %$href) {
2033
0
0
                my $aref = $href->{$k};
2034
0
0
                next unless ref $aref eq 'ARRAY';
2035
0
0
0
0
                my $vals = join(', ', map { perl_quote($_) } @$aref);
2036
0
0
                push @entries, '    ' . perl_quote($k) . " => [ $vals ]";
2037        }
2038
32
45
        return join(",\n", @entries);
2039}
2040
2041# Robustly quote a string (GitHub#1)
2042sub q_wrap
2043{
2044
11
16
        my $s = $_[0];
2045
2046
11
9
        return "''" if(!defined($s));
2047
2048
11
14
        for my $p ( ['{','}'], ['(',')'], ['[',']'], ['<','>'] ) {
2049
11
10
                my ($l, $r) = @$p;
2050
11
57
                return "q$l$s$r" unless $s =~ /\Q$l\E|\Q$r\E/;
2051        }
2052
0
0
        for my $d ('~', '!', '%', '^', '=', '+', ':', ',', ';', '|', '/', '#') {
2053
0
0
                return "q$d$s$d" unless index($s, $d) >= 0;
2054        }
2055
0
0
        (my $esc = $s) =~ s/'/\\'/g;
2056
0
0
        return "'$esc'";
2057}
2058
2059 - 2063
=head2 _generate_transform_properties

Converts transform specifications into LectroTest property definitions.

=cut
2064
2065sub _generate_transform_properties {
2066
4
6
        my ($transforms, $function, $module, $input, $config, $new) = @_;
2067
2068
4
5
        my @properties;
2069
2070
4
5
        for my $transform_name (sort keys %$transforms) {
2071
8
7
                my $transform = $transforms->{$transform_name};
2072
2073
8
7
                my $input_spec = $transform->{input};
2074
8
4
                my $output_spec = $transform->{output};
2075
2076                # Skip if input is 'undef'
2077
8
11
                if (!ref($input_spec) && $input_spec eq 'undef') {
2078
0
0
                        next;
2079                }
2080
2081                # Detect automatic properties from the transform spec
2082
8
21
                my @detected_props = _detect_transform_properties(
2083                        $transform_name,
2084                        $input_spec,
2085                        $output_spec
2086                );
2087
2088                # Process custom properties from schema
2089
8
7
                my @custom_props = ();
2090
8
8
                if (exists $transform->{properties} && ref($transform->{properties}) eq 'ARRAY') {
2091                        @custom_props = _process_custom_properties(
2092                                $transform->{properties},
2093
0
0
                                $function,
2094                                $module,
2095                                $input_spec,
2096                                $output_spec,
2097                                $new
2098                        );
2099                }
2100
2101                # Combine detected and custom properties
2102
8
10
                my @all_props = (@detected_props, @custom_props);
2103
2104                # Skip if no properties detected or defined
2105
8
6
                next unless @all_props;
2106
2107
8
6
                next unless ref($input_spec) eq 'HASH';
2108
2109                # Build LectroTest generator specification
2110
8
8
                my @generators;
2111                my @var_names;
2112
2113
8
6
                for my $field (sort keys %$input_spec) {
2114
8
5
                        my $spec = $input_spec->{$field};
2115
8
11
                        next unless ref($spec) eq 'HASH';
2116
2117
8
9
                        if(defined(my $gen = _schema_to_lectrotest_generator($field, $spec))) {
2118
8
8
                                if(length($gen)) {
2119
8
3
                                        push @generators, $gen;
2120
8
8
                                        push @var_names, $field;
2121                                }
2122                        }
2123                }
2124
2125
8
10
                my $gen_spec = join(', ', @generators);
2126
2127                # Build the call code
2128
8
6
                my $call_code;
2129
8
23
                if($module && defined($new)) {
2130
0
0
                        $call_code = "my \$obj = new_ok('$module');";
2131
0
0
                        $call_code .= "\$obj->$function";  # Method call
2132                } elsif($module && $module ne 'builtin') {
2133                        # $call_code = "$module->$function";
2134
0
0
                        $call_code = "$module\::$function";
2135                } else {
2136
8
6
                        $call_code = $function;
2137                }
2138
2139                # Build argument list (respect positions if defined)
2140
8
4
                my @args;
2141
8
8
                if (_has_positions($input_spec)) {
2142                        my @sorted = sort {
2143
8
8
                                $input_spec->{$a}{position} <=> $input_spec->{$b}{position}
2144
0
0
                        } keys %$input_spec;
2145
8
8
10
9
                        @args = map { "\$$_" } @sorted;
2146                } else {
2147
0
0
0
0
                        @args = map { "\$$_" } @var_names;
2148                }
2149
8
8
                my $args_str = join(', ', @args);
2150
2151                # Build property checks
2152
8
28
9
20
                my @checks = map { $_->{code} } @all_props;
2153
8
10
                my $property_checks = join(" &&\n\t", @checks);
2154
2155                # Handle _STATUS in output
2156
8
15
                my $should_die = ($output_spec->{_STATUS} // '') eq 'DIES';
2157
8
16
                my $should_warn = ($output_spec->{_STATUS} // '') eq 'WARN';
2158
2159                push @properties, {
2160                        name => $transform_name,
2161                        generator_spec => $gen_spec,
2162                        call_code => "$call_code($args_str)",
2163                        property_checks => $property_checks,
2164                        should_die => $should_die,
2165                        should_warn => $should_warn,
2166
8
39
                        trials => $config->{properties}{trials} // DEFAULT_PROPERTY_TRIALS,
2167                };
2168        }
2169
2170
4
4
        return \@properties;
2171}
2172
2173 - 2177
=head2 _process_custom_properties

Processes custom property definitions from the schema.

=cut
2178
2179sub _process_custom_properties {
2180
0
0
        my ($properties_spec, $function, $module, $input_spec, $output_spec, $schema) = @_;
2181
2182
0
0
        my @properties;
2183
0
0
        my $builtin_properties = _get_builtin_properties();
2184
0
0
        my $new = defined($schema->{'new'}) ? $schema->{new} : '_UNDEF';
2185
2186
0
0
        for my $prop_def (@$properties_spec) {
2187
0
0
                my $prop_name;
2188                my $prop_code;
2189
0
0
                my $prop_desc;
2190
2191
0
0
                if (!ref($prop_def)) {
2192                        # Simple string - lookup builtin property
2193
0
0
                        $prop_name = $prop_def;
2194
2195
0
0
                        if (exists $builtin_properties->{$prop_name}) {
2196
0
0
                                my $builtin = $builtin_properties->{$prop_name};
2197
2198                                # Get input variable names
2199
0
0
                                my @var_names = sort keys %$input_spec;
2200
2201                                # Build args
2202
0
0
                                my @args;
2203
0
0
                                if (_has_positions($input_spec)) {
2204                                        my @sorted = sort {
2205
0
0
                                                $input_spec->{$a}{position} <=> $input_spec->{$b}{position}
2206
0
0
                                        } @var_names;
2207
0
0
0
0
                                        @args = map { "\$$_" } @sorted;
2208                                } else {
2209
0
0
0
0
                                        @args = map { "\$$_" } @var_names;
2210                                }
2211
2212                                # Build call code
2213
0
0
                                my $call_code;
2214                                # Check if this is OO mode
2215
0
0
                                if($module && defined($new)) {
2216
0
0
                                        $call_code = "my \$obj = new_ok('$module');";
2217
0
0
                                        $call_code .= "\$obj->$function";  # Method call
2218                                } elsif($module && $module ne 'builtin') {
2219
0
0
                                        $call_code = "$module\::$function";   # Function call
2220                                } else {
2221
0
0
                                        $call_code = $function; # Builtin
2222                                }
2223
0
0
                                $call_code .= '(' . join(', ', @args) . ')';
2224
2225                                # Generate property code from template
2226
0
0
                                $prop_code = $builtin->{code_template}->($function, $call_code, \@var_names);
2227
0
0
                                $prop_desc = $builtin->{description};
2228                        } else {
2229
0
0
                                carp "Unknown built-in property '$prop_name', skipping";
2230
0
0
                                next;
2231                        }
2232                } elsif (ref($prop_def) eq 'HASH') {
2233                        # Custom property with code
2234
0
0
                        $prop_name = $prop_def->{name} || 'custom_property';
2235
0
0
                        $prop_code = $prop_def->{code};
2236
0
0
                        $prop_desc = $prop_def->{description} || "Custom property: $prop_name";
2237
2238
0
0
                        unless ($prop_code) {
2239
0
0
                                carp "Custom property '$prop_name' missing 'code' field, skipping";
2240
0
0
                                next;
2241                        }
2242
2243                        # Validate that the code looks reasonable
2244
0
0
                        unless ($prop_code =~ /\$/ || $prop_code =~ /\w+/) {
2245
0
0
                                carp "Custom property '$prop_name' code looks invalid: $prop_code";
2246
0
0
                                next;
2247                        }
2248                }
2249                else {
2250
0
0
                        carp 'Invalid property definition: ', Dumper($prop_def);
2251
0
0
                        next;
2252                }
2253
2254
0
0
                push @properties, {
2255                        name => $prop_name,
2256                        code => $prop_code,
2257                        description => $prop_desc,
2258                };
2259        }
2260
2261
0
0
        return @properties;
2262}
2263
2264 - 2268
=head2 _detect_transform_properties

Automatically detects testable properties from transform input/output specs.

=cut
2269
2270sub _detect_transform_properties {
2271
8
8
        my ($transform_name, $input_spec, $output_spec) = @_;
2272
2273
8
3
        my @properties;
2274
2275        # Skip if input is 'undef'
2276
8
9
        return @properties if (!ref($input_spec) && $input_spec eq 'undef');
2277
2278        # Property 1: Output range constraints (numeric)
2279
8
8
        if (_is_numeric_transform($input_spec, $output_spec)) {
2280
8
8
                if (defined $output_spec->{min}) {
2281
8
4
                        my $min = $output_spec->{min};
2282
8
23
                        push @properties, {
2283                                name => 'min_constraint',
2284                                # code => "\$result >= $min"
2285                                code => "defined(\$result) && looks_like_number(\$result) && \$result >= $min"
2286                        };
2287                }
2288
2289
8
8
                if (defined $output_spec->{max}) {
2290
0
0
                        my $max = $output_spec->{max};
2291
0
0
                        push @properties, {
2292                                name => 'max_constraint',
2293                                # code => "\$result <= $max"
2294                                code => "defined(\$result) && looks_like_number(\$result) && \$result <= $max"
2295                        };
2296                }
2297
2298                # For transforms, add an idempotence check where appropriate
2299                # e.g., abs(abs(x)) == abs(x)
2300
8
17
                if ($transform_name =~ /positive/i) {
2301
4
5
                        push @properties, {
2302                                name => 'non_negative',
2303                                # code => "\$result >= 0"
2304                                code => "defined(\$result) && looks_like_number(\$result) && \$result >= 0"
2305                        };
2306                }
2307        }
2308
2309        # Property 2: Specific value output
2310
8
8
        if (defined $output_spec->{value}) {
2311
0
0
                my $expected = $output_spec->{value};
2312
0
0
                push @properties, {
2313                        name => 'exact_value',
2314                        # code => "\$result == $expected"
2315                        (ref($expected))
2316                        ? "\$result == $expected"  # maybe
2317                        : "\$result eq " . perl_quote($expected)
2318                };
2319        }
2320
2321        # Property 3: String length constraints
2322
8
7
        if (_is_string_transform($input_spec, $output_spec)) {
2323
0
0
                if (defined $output_spec->{min}) {
2324
0
0
                        push @properties, {
2325                                name => 'min_length',
2326                                code => "length(\$result) >= $output_spec->{min}"
2327                        };
2328                }
2329
2330
0
0
                if (defined $output_spec->{max}) {
2331
0
0
                        push @properties, {
2332                                name => 'max_length',
2333                                code => "length(\$result) <= $output_spec->{max}"
2334                        };
2335                }
2336
2337
0
0
                if (defined $output_spec->{matches}) {
2338
0
0
                        my $pattern = $output_spec->{matches};
2339
0
0
                        push @properties, {
2340                                name => 'pattern_match',
2341                                code => "\$result =~ qr/$pattern/"
2342                        };
2343                }
2344        }
2345
2346        # Property 4: Type preservation
2347
8
8
        if (_same_type($input_spec, $output_spec)) {
2348
8
6
                my $type = _get_dominant_type($output_spec);
2349
2350
8
14
                if ($type eq 'number' || $type eq 'integer' || $type eq 'float') {
2351
8
12
                        push @properties, {
2352                                name => 'numeric_type',
2353                                code => "looks_like_number(\$result)"
2354                        };
2355                }
2356        }
2357
2358        # Property 5: Definedness (unless output can be undef)
2359
8
12
        unless (($output_spec->{type} // '') eq 'undef') {
2360
8
8
                push @properties, {
2361                        name => 'defined',
2362                        code => "defined(\$result)"
2363                };
2364        }
2365
2366
8
9
        return @properties;
2367}
2368
2369 - 2373
=head2 _get_semantic_generators

Returns a hash of built-in semantic generators for common data types.

=cut
2374
2375sub _get_semantic_generators {
2376        return {
2377
17
510
                email => {
2378                        code => q{
2379                                Gen {
2380                                        my $len = 5 + int(rand(10));
2381                                        my @addr;
2382                                        my @tlds = qw(com org net edu gov io co uk de fr);
2383
2384                                        for(my $i = 0; $i < $len; $i++) {
2385                                                push @addr, pack('c', (int(rand 26))+97);
2386                                        }
2387                                        push @addr, '@';
2388                                        $len = 5 + int(rand(10));
2389                                        for(my $i = 0; $i < $len; $i++) {
2390                                                push @addr, pack('c', (int(rand 26))+97);
2391                                        }
2392                                        push @addr, '.';
2393                                        $len = rand($#tlds+1);
2394                                        push @addr, $tlds[$len];
2395                                        return join('', @addr);
2396                                }
2397                        },
2398                        description => 'Valid email addresses',
2399                },
2400                url => {
2401                        code => q{
2402                                Gen {
2403                                        my @schemes = qw(http https);
2404                                        my @tlds = qw(com org net io);
2405                                        my $scheme = $schemes[int(rand(@schemes))];
2406                                        my $domain = join('', map { ('a'..'z')[int(rand(26))] } 1..(5 + int(rand(10))));
2407                                        my $tld = $tlds[int(rand(@tlds))];
2408                                        my $path = join('', map { ('a'..'z', '0'..'9', '-', '_')[int(rand(38))] } 1..int(rand(20)));
2409
2410                                        return "$scheme://$domain.$tld" . ($path ? "/$path" : '');
2411                                }
2412                        },
2413                        description => 'Valid HTTP/HTTPS URLs',
2414                },
2415
2416                uuid => {
2417                        code => q{
2418                                Gen {
2419                                        sprintf('%08x-%04x-%04x-%04x-%012x',
2420                                                int(rand(0xffffffff)),
2421                                                int(rand(0xffff)),
2422                                                (int(rand(0xffff)) & 0x0fff) | 0x4000,
2423                                                (int(rand(0xffff)) & 0x3fff) | 0x8000,
2424                                                int(rand(0x1000000000000))
2425                                        );
2426                                }
2427                        },
2428                        description => 'Valid UUIDv4 identifiers',
2429                },
2430
2431                phone_us => {
2432                        code => q{
2433                                Gen {
2434                                        my $area = 200 + int(rand(800));
2435                                        my $exchange = 200 + int(rand(800));
2436                                        my $subscriber = int(rand(10000));
2437                                        sprintf('%03d-%03d-%04d', $area, $exchange, $subscriber);
2438                                }
2439                        },
2440                        description => 'US phone numbers (XXX-XXX-XXXX format)',
2441                },
2442
2443                phone_e164 => {
2444                        code => q{
2445                                Gen {
2446                                        my $country = 1 + int(rand(999));
2447                                        my $area = 100 + int(rand(900));
2448                                        my $number = int(rand(10000000));
2449                                        sprintf('+%d%03d%07d', $country, $area, $number);
2450                                }
2451                        },
2452                        description => 'E.164 international phone numbers',
2453                },
2454
2455                ipv4 => {
2456                        code => q{
2457                                Gen {
2458                                        join('.', map { int(rand(256)) } 1..4);
2459                                }
2460                        },
2461                        description => 'IPv4 addresses',
2462                },
2463
2464                ipv6 => {
2465                        code => q{
2466                                Gen {
2467                                        join(':', map { sprintf('%04x', int(rand(0x10000))) } 1..8);
2468                                }
2469                        },
2470                        description => 'IPv6 addresses',
2471                },
2472
2473                username => {
2474                        code => q{
2475                                Gen {
2476                                        my $len = 3 + int(rand(13));
2477                                        my @chars = ('a'..'z', '0'..'9', '_', '-');
2478                                        my $first = ('a'..'z')[int(rand(26))];
2479                                        $first . join('', map { $chars[int(rand(@chars))] } 1..($len-1));
2480                                }
2481                        },
2482                        description => 'Valid usernames (alphanumeric with _ and -)',
2483                },
2484
2485                slug => {
2486                        code => q{
2487                                Gen {
2488                                        my @words = qw(quick brown fox jumps over lazy dog hello world test data);
2489                                        my $count = 1 + int(rand(4));
2490                                        join('-', map { $words[int(rand(@words))] } 1..$count);
2491                                }
2492                        },
2493                        description => 'URL slugs (lowercase words separated by hyphens)',
2494                },
2495
2496                hex_color => {
2497                        code => q{
2498                                Gen {
2499                                        sprintf('#%06x', int(rand(0x1000000)));
2500                                }
2501                        },
2502                        description => 'Hex color codes (#RRGGBB)',
2503                },
2504
2505                iso_date => {
2506                        code => q{
2507                                Gen {
2508                                        my $year = 2000 + int(rand(25));
2509                                        my $month = 1 + int(rand(12));
2510                                        my $day = 1 + int(rand(28));
2511                                        sprintf('%04d-%02d-%02d', $year, $month, $day);
2512                                }
2513                        },
2514                        description => 'ISO 8601 date format (YYYY-MM-DD)',
2515                },
2516
2517                iso_datetime => {
2518                        code => q{
2519                                Gen {
2520                                        my $year = 2000 + int(rand(25));
2521                                        my $month = 1 + int(rand(12));
2522                                        my $day = 1 + int(rand(28));
2523                                        my $hour = int(rand(24));
2524                                        my $minute = int(rand(60));
2525                                        my $second = int(rand(60));
2526                                        sprintf('%04d-%02d-%02dT%02d:%02d:%02dZ',
2527                                                $year, $month, $day, $hour, $minute, $second);
2528                                }
2529                        },
2530                        description => 'ISO 8601 datetime format (YYYY-MM-DDTHH:MM:SSZ)',
2531                },
2532
2533                semver => {
2534                        code => q{
2535                                Gen {
2536                                        my $major = int(rand(10));
2537                                        my $minor = int(rand(20));
2538                                        my $patch = int(rand(50));
2539                                        "$major.$minor.$patch";
2540                                }
2541                        },
2542                        description => 'Semantic version strings (major.minor.patch)',
2543                },
2544
2545                jwt => {
2546                        code => q{
2547                                Gen {
2548                                        my @chars = ('A'..'Z', 'a'..'z', '0'..'9', '-', '_');
2549                                        my $header = join('', map { $chars[int(rand(@chars))] } 1..20);
2550                                        my $payload = join('', map { $chars[int(rand(@chars))] } 1..40);
2551                                        my $signature = join('', map { $chars[int(rand(@chars))] } 1..30);
2552                                        "$header.$payload.$signature";
2553                                }
2554                        },
2555                        description => 'JWT-like tokens (base64url format)',
2556                },
2557
2558                json => {
2559                        code => q{
2560                                Gen {
2561                                        my @keys = qw(id name value status count);
2562                                        my $key = $keys[int(rand(@keys))];
2563                                        my $value = 1 + int(rand(1000));
2564                                        qq({"$key":$value});
2565                                }
2566                        },
2567                        description => 'Simple JSON objects',
2568                },
2569
2570                base64 => {
2571                        code => q{
2572                                Gen {
2573                                        my @chars = ('A'..'Z', 'a'..'z', '0'..'9', '+', '/');
2574                                        my $len = 12 + int(rand(20));
2575                                        my $str = join('', map { $chars[int(rand(@chars))] } 1..$len);
2576                                        $str .= '=' x (4 - ($len % 4)) if $len % 4;
2577                                        $str;
2578                                }
2579                        },
2580                        description => 'Base64-encoded strings',
2581                },
2582
2583                md5 => {
2584                        code => q{
2585                                Gen {
2586                                        join('', map { sprintf('%x', int(rand(16))) } 1..32);
2587                                }
2588                        },
2589                        description => 'MD5 hashes (32 hex characters)',
2590                },
2591
2592                sha256 => {
2593                        code => q{
2594                                Gen {
2595                                        join('', map { sprintf('%x', int(rand(16))) } 1..64);
2596                                }
2597                        },
2598                        description => 'SHA-256 hashes (64 hex characters)',
2599                },
2600
2601                unix_timestamp => {
2602                        code => q{
2603                                Gen {
2604                                        time;
2605                                }
2606                        }
2607                },
2608        };
2609}
2610
2611 - 2615
=head2 _get_builtin_properties

Returns a hash of built-in property templates that can be applied to transforms.

=cut
2616
2617sub _get_builtin_properties {
2618        return {
2619                idempotent => {
2620                        description => 'Function is idempotent: f(f(x)) == f(x)',
2621                        code_template => sub {
2622
0
0
                                my ($function, $call_code, $input_vars) = @_;
2623                                # Use string comparison - works for all types in Perl
2624
0
0
                                return "do { my \$tmp = $call_code; \$result eq \$tmp }";
2625                        },
2626                        applicable_to => ['all'],
2627                },
2628
2629                non_negative => {
2630                        description => 'Result is always non-negative',
2631                        code_template => sub {
2632
0
0
                                my ($function, $call_code, $input_vars) = @_;
2633
0
0
                                return '$result >= 0';
2634                        },
2635                        applicable_to => ['number', 'integer', 'float'],
2636                },
2637
2638                positive => {
2639                        description => 'Result is always positive (> 0)',
2640                        code_template => sub {
2641
0
0
                                my ($function, $call_code, $input_vars) = @_;
2642
0
0
                                return '$result > 0';
2643                        },
2644                        applicable_to => ['number', 'integer', 'float'],
2645                },
2646
2647                non_empty => {
2648                        description => 'Result is never empty',
2649                        code_template => sub {
2650
0
0
                                my ($function, $call_code, $input_vars) = @_;
2651
0
0
                                return 'length($result) > 0';
2652                        },
2653                        applicable_to => ['string'],
2654                },
2655
2656                length_preserved => {
2657                        description => 'Output length equals input length',
2658                        code_template => sub {
2659
0
0
                                my ($function, $call_code, $input_vars) = @_;
2660
0
0
                                my $first_var = $input_vars->[0];
2661
0
0
                                return "length(\$result) == length(\$$first_var)";
2662                        },
2663                        applicable_to => ['string'],
2664                },
2665
2666                uppercase => {
2667                        description => 'Result is all uppercase',
2668                        code_template => sub {
2669
0
0
                                my ($function, $call_code, $input_vars) = @_;
2670
0
0
                                return '$result eq uc($result)';
2671                        },
2672                        applicable_to => ['string'],
2673                },
2674
2675                lowercase => {
2676                        description => 'Result is all lowercase',
2677                        code_template => sub {
2678
0
0
                                my ($function, $call_code, $input_vars) = @_;
2679
0
0
                                return '$result eq lc($result)';
2680                        },
2681                        applicable_to => ['string'],
2682                },
2683
2684                trimmed => {
2685                        description => 'Result has no leading/trailing whitespace',
2686                        code_template => sub {
2687
0
0
                                my ($function, $call_code, $input_vars) = @_;
2688
0
0
                                return '$result !~ /^\s/ && $result !~ /\s$/';
2689                        },
2690                        applicable_to => ['string'],
2691                },
2692
2693                sorted_ascending => {
2694                        description => 'Array is sorted in ascending order',
2695                        code_template => sub {
2696
0
0
                                my ($function, $call_code, $input_vars) = @_;
2697
0
0
                                return 'do { my @arr = @$result; my $sorted = 1; for my $i (1..$#arr) { $sorted = 0 if $arr[$i] < $arr[$i-1]; } $sorted }';
2698                        },
2699                        applicable_to => ['arrayref'],
2700                },
2701
2702                sorted_descending => {
2703                        description => 'Array is sorted in descending order',
2704                        code_template => sub {
2705
0
0
                                my ($function, $call_code, $input_vars) = @_;
2706
0
0
                                return 'do { my @arr = @$result; my $sorted = 1; for my $i (1..$#arr) { $sorted = 0 if $arr[$i] > $arr[$i-1]; } $sorted }';
2707                        },
2708                        applicable_to => ['arrayref'],
2709                },
2710
2711                unique_elements => {
2712                        description => 'Array has no duplicate elements',
2713                        code_template => sub {
2714
0
0
                                my ($function, $call_code, $input_vars) = @_;
2715
0
0
                                return 'do { my @arr = @$result; my %seen; !grep { $seen{$_}++ } @arr }';
2716                        },
2717                        applicable_to => ['arrayref'],
2718                },
2719
2720                preserves_keys => {
2721                        description => 'Hash has same keys as input',
2722                        code_template => sub {
2723
0
0
                                my ($function, $call_code, $input_vars) = @_;
2724
0
0
                                my $first_var = $input_vars->[0];
2725
0
0
                                return 'do { my @in = sort keys %{$' . $first_var . '}; my @out = sort keys %$result; join(",", @in) eq join(",", @out) }';
2726                        },
2727                        applicable_to => ['hashref'],
2728                },
2729
2730                monotonic_increasing => {
2731                        description => 'For x <= y, f(x) <= f(y)',
2732                        code_template => sub {
2733
0
0
                                my ($function, $call_code, $input_vars) = @_;
2734                                # This would need multiple inputs - complex
2735
0
0
                                return '1';     # Placeholder
2736                        },
2737
4
119
                        applicable_to => ['number', 'integer'],
2738                },
2739        };
2740}
2741
2742 - 2746
=head2 _schema_to_lectrotest_generator

Converts a schema field spec to a LectroTest generator string.

=cut
2747
2748sub _schema_to_lectrotest_generator {
2749
11
559
        my ($field_name, $spec) = @_;
2750
2751
11
24
        my $type = $spec->{type} || 'string';
2752
2753        # Check for semantic generator first
2754
11
16
        if ($type eq 'string' && defined $spec->{semantic}) {
2755
0
0
                my $semantic_type = $spec->{semantic};
2756
0
0
                my $generators = _get_semantic_generators();
2757
2758
0
0
                if (exists $generators->{$semantic_type}) {
2759
0
0
                        my $gen_code = $generators->{$semantic_type}{code};
2760                        # Remove leading/trailing whitespace and compress
2761
0
0
                        $gen_code =~ s/^\s+//;
2762
0
0
                        $gen_code =~ s/\s+$//;
2763
0
0
                        $gen_code =~ s/\n\s+/ /g;
2764
0
0
                        return "$field_name <- $gen_code";
2765                } else {
2766
0
0
                        carp "Unknown semantic type '$semantic_type', falling back to regular string generator";
2767                        # Fall through to regular string generation
2768                }
2769        }
2770
2771
11
25
        if ($type eq 'integer') {
2772
1
1
                my $min = $spec->{min};
2773
1
1
                my $max = $spec->{max};
2774
2775
1
2
                if (!defined($min) && !defined($max)) {
2776
0
0
                        return "$field_name <- Int";
2777                } elsif (!defined($min)) {
2778
0
0
                        return "$field_name <- Int(sized => sub { int(rand($max + 1)) })";
2779                } elsif (!defined($max)) {
2780
0
0
                        return "$field_name <- Int(sized => sub { $min + int(rand(1000)) })";
2781                } else {
2782
1
1
                        my $range = $max - $min;
2783
1
3
                        return "$field_name <- Int(sized => sub { $min + int(rand($range + 1)) })";
2784                }
2785        }
2786        elsif ($type eq 'number' || $type eq 'float') {
2787
8
4
                my $min = $spec->{min};
2788
8
7
                my $max = $spec->{max};
2789
2790
8
25
                if (!defined($min) && !defined($max)) {
2791                        # No constraints - full range
2792
0
0
                        return "$field_name <- Float(sized => sub { rand(1000) - 500 })";
2793                } elsif (!defined($min)) {
2794                        # Only max defined
2795
4
6
                        if ($max == 0) {
2796                                # max=0 means negative numbers only
2797
4
9
                                return "$field_name <- Float(sized => sub { -rand(1000) })";
2798                        } elsif ($max > 0) {
2799                                # Positive max, generate 0 to max
2800
0
0
                                return "$field_name <- Float(sized => sub { rand($max) })";
2801                        } else {
2802                                # Negative max, generate from some negative to max
2803
0
0
                                return "$field_name <- Float(sized => sub { ($max - 1000) + rand(1000 + $max) })";
2804                        }
2805                } elsif (!defined($max)) {
2806                        # Only min defined
2807
4
5
                        if ($min == 0) {
2808                                # min=0 means positive numbers only
2809
4
7
                                return "$field_name <- Float(sized => sub { rand(1000) })";
2810                        } elsif ($min > 0) {
2811                                # Positive min
2812
0
0
                                return "$field_name <- Float(sized => sub { $min + rand(1000) })";
2813                        } else {
2814                                # Negative min
2815
0
0
                                return "$field_name <- Float(sized => sub { $min + rand(-$min + 1000) })";
2816                        }
2817                } else {
2818                        # Both min and max defined
2819
0
0
                        my $range = $max - $min;
2820
0
0
                        if ($range <= 0) {
2821
0
0
                                carp "Invalid range: min=$min, max=$max";
2822
0
0
                                return "$field_name <- Float(sized => sub { $min })";
2823                        }
2824
0
0
                        return "$field_name <- Float(sized => sub { $min + rand($range) })";
2825                }
2826        }
2827        elsif ($type eq 'string') {
2828
1
1
                my $min_len = $spec->{min} // 0;
2829
1
2
                my $max_len = $spec->{max} // 100;
2830
2831                # Handle regex patterns
2832
1
1
                if (defined $spec->{matches}) {
2833
0
0
                        my $pattern = $spec->{matches};
2834
2835                        # Build generator using Data::Random::String::Matches
2836
0
0
                        if (defined $spec->{max}) {
2837
0
0
                                return "$field_name <- Gen { Data::Random::String::Matches->create_random_string({ regex => qr/$pattern/, length => $spec->{max} }) }";
2838                        } elsif (defined $spec->{min}) {
2839
0
0
                                return "$field_name <- Gen { Data::Random::String::Matches->create_random_string({ regex => qr/$pattern/, length => $spec->{min} }) }";
2840                        } else {
2841
0
0
                                return "$field_name <- Gen { Data::Random::String::Matches->create_random_string({ regex => qr/$pattern/ }) }";
2842                        }
2843                }
2844
2845
1
9
                return "$field_name <- String(length => [$min_len, $max_len])";
2846        } elsif ($type eq 'boolean') {
2847
0
0
                return "$field_name <- Bool";
2848        }
2849        elsif ($type eq 'arrayref') {
2850
0
0
                my $min_size = $spec->{min} // 0;
2851
0
0
                my $max_size = $spec->{max} // 10;
2852
0
0
                return "$field_name <- List(Int, length => [$min_size, $max_size])";
2853        }
2854        elsif ($type eq 'hashref') {
2855                # LectroTest doesn't have built-in Hash, use custom generator
2856
1
1
                my $min_keys = $spec->{min} // 0;
2857
1
1
                my $max_keys = $spec->{max} // 10;
2858
1
2
                return "$field_name <- Elements(map { my \%h; for (1..\$_) { \$h{'key'.\$_} = \$_ }; \\\%h } $min_keys..$max_keys)";
2859        }
2860        else {
2861
0
0
                carp "Unknown type '$type' for LectroTest generator, using String";
2862
0
0
                return "$field_name <- String";
2863        }
2864}
2865
2866 - 2868
=head2 Helper functions for type detection

=cut
2869
2870sub _is_numeric_transform {
2871
8
7
        my ($input_spec, $output_spec) = @_;
2872
2873
8
21
        my $out_type = $output_spec->{type} // '';
2874
8
28
        return $out_type eq 'number' || $out_type eq 'integer' || $out_type eq 'float';
2875}
2876
2877sub _is_string_transform {
2878
8
8
        my ($input_spec, $output_spec) = @_;
2879
2880
8
9
        my $out_type = $output_spec->{type} // '';
2881
8
9
        return $out_type eq 'string';
2882}
2883
2884sub _same_type {
2885
8
7
        my ($input_spec, $output_spec) = @_;
2886
2887        # Simplified - would need more sophisticated logic for multiple inputs
2888
8
8
        my $in_type = _get_dominant_type($input_spec);
2889
8
9
        my $out_type = _get_dominant_type($output_spec);
2890
2891
8
12
        return $in_type eq $out_type;
2892}
2893
2894sub _get_dominant_type {
2895
24
10
        my $spec = $_[0];
2896
2897
24
26
        return $spec->{type} if defined $spec->{type};
2898
2899        # For multi-field specs, return the first type found
2900
8
11
        for my $field (keys %$spec) {
2901
8
9
                next unless ref($spec->{$field}) eq 'HASH';
2902
8
14
                return $spec->{$field}{type} if defined $spec->{$field}{type};
2903        }
2904
2905
0
0
        return 'string';        # Default
2906}
2907
2908sub _has_positions {
2909
24
16
        my $input_spec = $_[0];
2910
2911
24
25
        for my $field (keys %$input_spec) {
2912
23
25
                next unless ref($input_spec->{$field}) eq 'HASH';
2913
18
25
                return 1 if defined $input_spec->{$field}{position};
2914        }
2915
2916
12
13
        return 0;
2917}
2918
2919 - 2923
=head2 _render_properties

Renders property definitions into Perl code for the template.

=cut
2924
2925sub _render_properties {
2926
4
4
        my $properties = $_[0];
2927
2928
4
4
        my $code = "use_ok('Test::LectroTest::Compat');\n\n";
2929
2930
4
4
        for my $prop (@$properties) {
2931
8
8
                $code .= "# Transform property: $prop->{name}\n";
2932
8
8
                $code .= "my \$$prop->{name} = Property {\n";
2933
8
6
                $code .= "    ##[ $prop->{generator_spec} ]##\n";
2934
8
5
                $code .= "    \n";
2935
8
8
                $code .= "    my \$result = eval { $prop->{call_code} };\n";
2936
2937
8
9
                if ($prop->{should_die}) {
2938
0
0
                        $code .= "    my \$died = defined(\$\@) && \$\@;\n";
2939
0
0
                        $code .= "    \$died;\n";
2940                } else {
2941
8
7
                        $code .= "    my \$error = \$\@;\n";
2942                        # $code .= "    diag(\"\$$prop->{name} -> \$error; \") if(\$ENV{'TEST_VERBOSE'});\n";
2943
8
4
                        $code .= "    \n";
2944
8
6
                        $code .= "    !\$error && (\n";
2945
8
7
                        $code .= "        $prop->{property_checks}\n";
2946
8
9
                        $code .= "    );\n";
2947                }
2948
2949
8
6
                $code .= "}, name => '$prop->{name}', trials => $prop->{trials};\n\n";
2950
2951
8
5
                $code .= "holds(\$$prop->{name});\n";
2952        }
2953
2954
4
10
        return $code;
2955}
2956
29571;
2958
2959 - 2994
=head1 NOTES

C<seed> and C<iterations> really should be within C<config>.

=head1 SEE ALSO

=over 4

=item * L<Test Coverage Report|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.

=cut
2995
2996 - 3014
=head1 LICENCE AND COPYRIGHT

Copyright 2025-2026 Nigel Horne.

Usage is subject to licence terms.

The licence terms of this software are as follows:

=over 4

=item * Personal single user, single computer use: GPL2

=item * All other users (including Commercial, Charity, Educational, Government)
  must apply in writing for a licence for use from Nigel Horne at the
  above e-mail.

=back

=cut
3015
30161;