lib/App/Test/Generator.pm

        start → end → jump
        

    1: package App::Test::Generator;
    2: 
    3: # TODO: Test validator from Params::Validate::Strict 0.16
    4: # TODO: $seed should be passed to Data::Random::String::Matches
    5: # TODO: positional args - when config_undef is set, see what happens when not all args are given
    6: # TODO: The Dup and TER1/2/3 columns should be moved from the Mutation table
    7: #	to a new table called Metrics.  Add Halstead and McCabes metrics to
    8: #	this new Metrics table.  Include links to the definitions of TER1/2/3,
    9: #	Halstead and McCabes metrics, perhaps from Wikipedia
   10: 
   11: use 5.036;
   12: 
   13: use strict;
   14: use warnings;
   15: use autodie qw(:all);
   16: 
   17: use utf8;
   18: use open qw(:std :encoding(UTF-8));
   19: 
   20: use App::Test::Generator::Template;
   21: use Carp qw(carp croak confess);
   22: use Config::Abstraction 0.36;
   23: use Data::Dumper;
   24: use Data::Section::Simple;
   25: use File::Basename qw(basename);
   26: use File::Spec;
   27: use Module::Load::Conditional qw(check_install can_load);
   28: use Params::Get;
   29: use Params::Validate::Strict 0.36;
   30: use Readonly;
   31: use Readonly::Values::Boolean;
   32: use Scalar::Util qw(looks_like_number);
   33: use re 'regexp_pattern';
   34: use Template;
   35: use YAML::XS qw(LoadFile);
   36: 
   37: use Exporter 'import';
   38: 
   39: our @EXPORT_OK = qw(generate);
   40: 
   41: our $VERSION = '0.46';
   42: 
   43: Readonly my $DEFAULT_ITERATIONS      => 30;
   44: Readonly my $DEFAULT_PROPERTY_TRIALS => 1000;
   45: 
   46: # Hash for O(1) lookup rather than a list needing grep O(n)
   47: Readonly my %VALID_CONFIG_KEYS => map { $_ => 1 } qw(
   48: 	test_nuls test_undef test_empty test_non_ascii
   49: 	dedup properties close_stdin test_security timeout
   50: );
   51: 
   52: # --------------------------------------------------
   53: # Delimiter pairs tried in order when wrapping a
   54: # string with q{} — bracket forms are preferred as
   55: # they are most readable in generated test code
   56: # --------------------------------------------------
   57: Readonly my @Q_BRACKET_PAIRS => (
   58: 	['{', '}'],
   59: 	['(', ')'],
   60: 	['[', ']'],
   61: 	['<', '>'],
   62: );
   63: 
   64: # --------------------------------------------------
   65: # Single-character delimiters tried when no bracket
   66: # pair is usable — each is tried in order and the
   67: # first one not present in the string is used.
   68: # The # character is last since it starts comments
   69: # in many contexts and is least readable
   70: # --------------------------------------------------
   71: Readonly my @Q_SINGLE_DELIMITERS => (
   72: 	'~', '!', '%', '^', '=', '+', ':', ',', ';', '|', '/', '#'
   73: );
   74: 
   75: # --------------------------------------------------
   76: # Sentinel returned by index() when the search
   77: # string is not found — used to make the >= 0
   78: # boundary check self-documenting and to prevent
   79: # NumericBoundary mutants from surviving
   80: # --------------------------------------------------
   81: Readonly my $INDEX_NOT_FOUND => -1;
   82: 
   83: # --------------------------------------------------
   84: # Readonly constants for schema validation
   85: # --------------------------------------------------
   86: Readonly my $CONFIG_PROPERTIES_KEY => 'properties';
   87: Readonly my $LEGACY_PERL_KEY_1     => '$module';
   88: Readonly my $LEGACY_PERL_KEY_2     => 'our $module';
   89: Readonly my $SOURCE_KEY            => '_source';
   90: 
   91: # --------------------------------------------------
   92: # Readonly constants for render_hash key detection
   93: # --------------------------------------------------
   94: Readonly my $KEY_MATCHES => 'matches';
   95: Readonly my $KEY_NOMATCH => 'nomatch';
   96: 
   97: # --------------------------------------------------
   98: # Reserved module name indicating a Perl builtin
   99: # function rather than a CPAN or user module
  100: # --------------------------------------------------
  101: Readonly my $MODULE_BUILTIN => 'builtin';
  102: 
  103: # --------------------------------------------------
  104: # Regex pattern matched against transform names to
  105: # detect the positive/non-negative idempotence
  106: # heuristic in _detect_transform_properties
  107: # --------------------------------------------------
  108: Readonly my $TRANSFORM_POSITIVE_PATTERN => 'positive';
  109: 
  110: # --------------------------------------------------
  111: # Default type assumed for schema fields that declare
  112: # no explicit type — used in generator selection and
  113: # dominant-type detection
  114: # --------------------------------------------------
  115: Readonly my $DEFAULT_FIELD_TYPE => 'string';
  116: 
  117: # --------------------------------------------------
  118: # Default range used by the LectroTest float/integer
  119: # generators when no min or max constraint is given.
  120: # Chosen to provide a useful spread without producing
  121: # values so large they overflow downstream arithmetic.
  122: # --------------------------------------------------
  123: Readonly my $DEFAULT_GENERATOR_RANGE => 1000;
  124: 
  125: # --------------------------------------------------
  126: # Default upper bound on the number of elements in
  127: # generated arrayrefs and hashrefs when no max is
  128: # declared in the schema.
  129: # --------------------------------------------------
  130: Readonly my $DEFAULT_MAX_COLLECTION_SIZE => 10;
  131: 
  132: # --------------------------------------------------
  133: # Default upper bound on generated string length
  134: # when no max is declared in the schema.
  135: # --------------------------------------------------
  136: Readonly my $DEFAULT_MAX_STRING_LEN => 100;
  137: 
  138: # --------------------------------------------------
  139: # Sentinel for the zero boundary used in float
  140: # generator selection — comparing min/max against
  141: # this constant makes the boundary intent explicit
  142: # and prevents NumericBoundary mutants from surviving.
  143: # --------------------------------------------------
  144: Readonly my $ZERO_BOUNDARY => 0;
  145: 
  146: # --------------------------------------------------
  147: # Environment variable names used to control verbose
  148: # output and optional load validation in
  149: # _validate_module. Centralised here so they are
  150: # easy to find and consistent across the codebase.
  151: # --------------------------------------------------
  152: Readonly my $ENV_TEST_VERBOSE       => 'TEST_VERBOSE';
  153: Readonly my $ENV_GENERATOR_VERBOSE  => 'GENERATOR_VERBOSE';
  154: Readonly my $ENV_VALIDATE_LOAD      => 'GENERATOR_VALIDATE_LOAD';
  155: 
  156: =head1 NAME
  157: 
  158: App::Test::Generator - Fuzz Testing, Mutation Testing, LCSAJ Metrics and Test Dashboard for Perl modules
  159: 
  160: =head1 VERSION
  161: 
  162: Version 0.46
  163: 
  164: =head1 SYNOPSIS
  165: 
  166: C<App::Test::Generator> is a suite to help the testing of CPAN modules.
  167: It consists of 6 subsystems:
  168: 
  169: =over 4
  170: 
  171: =item * Fuzz Tester
  172: 
  173: =item * Mutation Testing
  174: 
  175: =item * LCSAJ Metrics
  176: 
  177: =item * Test Dashboard
  178: 
  179: =item * Benchmark Generation
  180: 
  181: =item * Workflow Deployment
  182: 
  183: =back
  184: 
  185: From the command line:
  186: 
  187:   # Takes the formal definition of a routine, creates tests against that routine, and runs the test
  188:   fuzz-harness-generator -r t/conf/abs.yml
  189: 
  190:   # Attempt to create a formal definition from a routine package, then run tests against that formal definition
  191:   # This is the holy grail of test generation, a set of tests is automatically created directly from the source code,
  192:   extract-schemas lib/App/Test/Generator/Sample/Module.pm && fuzz-harness-generator -r schemas/greet.yml
  193: 
  194:   # Fuzz a module and keep the corpus bounded: trim to the minimum subset that still covers every branch
  195:   extract-schemas --fuzz --minimize-corpus lib/My/Module.pm
  196: 
  197:   # Generate round-trip tests that run every code example in a module's POD and verify the results
  198:   pod-example-tester lib/My/Module.pm --output t/pod_examples.t
  199: 
  200:   # Generate a Benchmark::cmpthese script from a schema; each transform becomes one timed variant
  201:   benchmark-generator -i schemas/abs.yml -o benchmarks/abs.pl
  202: 
  203:   # Copy dashboard.yml and mutate.yml into a module repository's .github/workflows/ directory
  204:   deploy-workflows --target /path/to/my-module
  205: 
  206: From Perl:
  207: 
  208:   use App::Test::Generator qw(generate);
  209:   use App::Test::Generator::SchemaExtractor;
  210: 
  211:   # Generate to STDOUT
  212:   App::Test::Generator->generate("t/conf/abs.yml");
  213: 
  214:   # Generate directly to a file
  215:   App::Test::Generator->generate('t/conf/abs.yml', 't/add_fuzz.t');
  216: 
  217:   # Holy grail mode - read a Perl file, generate tests, and run them
  218:   # This is a long way away yet, but see t/schema_input.t for a proof of concept
  219:   my $extractor = App::Test::Generator::SchemaExtractor->new(
  220:     input_file => 'lib/App/Test/Generator/Template.pm',
  221:     output_dir => '/tmp',
  222:   );
  223:   my $schemas = $extractor->extract_all();
  224:   use File::Temp qw(tempfile);
  225:   foreach my $schema(keys %{$schemas}) {
  226:     my ($fh, $tempfile) = tempfile(SUFFIX => '.t', UNLINK => 1);
  227:     close $fh;
  228:     App::Test::Generator->generate(
  229:       schema => $schemas->{$schema},
  230:       output_file => $tempfile,
  231:     );
  232:     system($^X, '-Ilib', $tempfile);
  233:   }
  234: 
  235: =head1 OVERVIEW
  236: 
  237: This module takes a formal input/output specification for a routine or
  238: method and automatically generates test cases. In effect, it allows you
  239: to easily add comprehensive black-box tests in addition to the more
  240: common white-box tests that are typically written for CPAN modules and other
  241: subroutines.
  242: 
  243: The generated tests combine:
  244: 
  245: =over 4
  246: 
  247: =item * Random fuzzing based on input types
  248: 
  249: =item * Deterministic edge cases for min/max constraints
  250: 
  251: =item * Static corpus tests defined in Perl or YAML
  252: 
  253: =back
  254: 
  255: This approach strengthens your test suite by probing both expected and
  256: unexpected inputs, helping you to catch boundary errors, invalid data
  257: handling, and regressions without manually writing every case.
  258: 
  259: =head1 TOOLS
  260: 
  261: The distribution ships the following command-line tools:
  262: 
  263: =over 4
  264: 
  265: =item * L<benchmark-generator> - generate a self-contained L<Benchmark> C<cmpthese> script from a YAML schema. Each transform in the schema becomes one named variant; representative input values are derived from each parameter's type and range constraints.
  266: 
  267: =item * L<deploy-workflows> - copy C<dashboard.yml> and C<mutate.yml> into the target repository's C<.github/workflows/> directory. Both files are embedded verbatim in the script, so no ATG source tree is needed after installation. Supports C<--target>, C<--force>, and C<--dry-run>.
  268: 
  269: To add a test dashboard to your CPAN module: copy these scripts into your C<.github/workflows> directory,
  270: then commit the changes to GitHub and enable the page through C<Settings-Pages-branch = gh_pages>:
  271: 
  272: =over 4
  273: 
  274: =item * L<https://github.com/nigelhorne/App-Test-Generator/blob/master/.github/workflows/dashboard.yml>
  275: 
  276: =item * L<https://github.com/nigelhorne/App-Test-Generator/blob/master/.github/workflows/mutate.yml>
  277: 
  278: =back
  279: 
  280: =item * L<extract-schemas> - heuristically extract YAML parameter schemas from a C<.pm> file, with optional coverage-guided fuzzing (C<--fuzz>) and corpus minimization (C<--minimize-corpus>).
  281: 
  282: =item * L<fuzz-harness-generator> - generate a C<Test::Most> fuzzing harness from a YAML schema.
  283: 
  284: =item * L<pod-example-tester> - generate a C<Test::Most> round-trip test file from a module's POD code examples. Annotated examples (C<# returns value> / C<< # => value >>) get C<is()> assertions; unannotated verbatim blocks are wrapped in C<eval{}> and checked for no exception.
  285: 
  286: =item * L<test-generator-mutate> - run mutation testing against a module's test suite.
  287: 
  288: =item * L<test-generator-index> - generate the HTML test-quality dashboard, combining Devel::Cover statement/branch data, LCSAJ path coverage, mutation results, and CPAN Testers failure analysis. For each CPAN Testers FAIL report, also writes a self-contained shell script (C<cover_html/reproduce/reproduce-GUID.sh>) that pins every installed module at its exact failing version, enabling local reproduction of the failure environment.
  289: 
  290: =back
  291: 
  292: =head1 DESCRIPTION
  293: 
  294: This module implements the logic behind L<fuzz-harness-generator>.
  295: It parses configuration files (fuzz and/or corpus YAML), and
  296: produces a ready-to-run F<.t> test script to run through C<prove>.
  297: 
  298: It reads configuration files in any format,
  299: and optional YAML corpus files.
  300: All of the examples in this documentation are in C<YAML> format,
  301: other formats may not work as they aren't so heavily tested.
  302: It then generates a L<Test::Most>-based fuzzing harness combining:
  303: 
  304: =over 4
  305: 
  306: =item * Randomized fuzzing of inputs (with edge cases)
  307: 
  308: =item * Optional static corpus tests from Perl C<%cases> or YAML file (C<yaml_cases> key)
  309: 
  310: =item * Functional or OO mode (via C<$new>)
  311: 
  312: =item * Reproducible runs via C<$seed> and configurable iterations via C<$iterations>
  313: 
  314: =back
  315: 
  316: =head1 MUTATION-GUIDED TEST GENERATION
  317: 
  318: C<App::Test::Generator> includes a pipeline that automatically closes the
  319: feedback loop between mutation testing, schema extraction, and fuzz
  320: testing. The goal is that surviving mutants drive the creation of new
  321: tests that kill them on the next run, without manual intervention.
  322: 
  323: =head2 The Pipeline
  324: 
  325:     mutation survivor
  326:         |
  327:         v
  328:     SchemaExtractor extracts the schema for the enclosing sub
  329:         |
  330:         v
  331:     Schema augmented with boundary values from the mutant
  332:         |
  333:         v
  334:     Augmented schema written to t/conf/
  335:         |
  336:         v
  337:     t/fuzz.t picks up the new schema and runs fuzz tests
  338:         |
  339:         v
  340:     Mutation killed on next run
  341: 
  342: =head2 How to Use It
  343: 
  344: The pipeline is driven by three flags passed to
  345: C<bin/test-generator-index>, which is invoked automatically by
  346: C<bin/generate-test-dashboard> on each CI push.
  347: 
  348: =head3 Step 1: Generate TODO stubs for all survivors
  349: 
  350:     bin/test-generator-index --generate_mutant_tests=t
  351: 
  352: Produces C<t/mutant_YYYYMMDD_HHMMSS.t> containing:
  353: 
  354: =over 4
  355: 
  356: =item * TODO stubs for HIGH and MEDIUM difficulty survivors, with
  357: boundary value suggestions, environment variable hints, and the
  358: enclosing subroutine name for navigation context.
  359: 
  360: =item * Comment-only hints for LOW difficulty survivors.
  361: 
  362: =back
  363: 
  364: Multiple mutations on the same source line are deduplicated into one
  365: stub. One good test kills all variants on that line.
  366: 
  367: =head3 Step 2: Generate runnable schemas for NUM_BOUNDARY survivors
  368: 
  369:     bin/test-generator-index \
  370:         --generate_mutant_tests=t \
  371:         --generate_test=mutant
  372: 
  373: For each NUM_BOUNDARY survivor, calls
  374: L<App::Test::Generator::SchemaExtractor> to extract the schema for
  375: the enclosing subroutine. If the confidence level is sufficient, the
  376: schema is augmented with the boundary value from the mutant (plus one
  377: value either side) and written to C<t/conf/> as a runnable YAML file.
  378: L<t/fuzz.t> picks it up automatically on the next test run.
  379: 
  380: Falls back to a TODO stub if:
  381: 
  382: =over 4
  383: 
  384: =item * SchemaExtractor cannot parse the file
  385: 
  386: =item * The enclosing sub cannot be determined
  387: 
  388: =item * The extracted schema confidence is C<very_low> or C<none>
  389: 
  390: =back
  391: 
  392: =head3 Step 3: Augment existing schemas with survivor boundary values
  393: 
  394:     bin/test-generator-index \
  395:         --generate_mutant_tests=t \
  396:         --generate_test=mutant \
  397:         --generate_fuzz
  398: 
  399: Scans C<t/conf/> for existing YAML schema files (hand-written or
  400: previously generated) and writes augmented copies with boundary values
  401: from surviving NUM_BOUNDARY mutants merged in. The original schema is
  402: never modified. Augmented copies are written as
  403: C<t/conf/mutant_fuzz_YYYYMMDD_HHMMSS_FUNCTION.yml> and picked up
  404: automatically by C<t/fuzz.t>.
  405: 
  406: Schemas whose filename already starts with C<mutant_fuzz_> are skipped
  407: to prevent cascading augmentation. Schemas with no matching survivors
  408: are skipped, with a note if C<--verbose> is active.
  409: 
  410: =head3 Putting It All Together
  411: 
  412: The recommended invocation in C<bin/generate-test-dashboard>
  413: Step 7 runs all three stages together:
  414: 
  415:     bin/test-generator-index \
  416:         --generate_mutant_tests=t \
  417:         --generate_test=mutant \
  418:         --generate_fuzz
  419: 
  420: The GitHub Actions workflow in C<.github/workflows/dashboard.yml>
  421: then commits any new C<t/mutant_*.t> and C<t/conf/mutant_*.yml> files
  422: to the repository so they accumulate over time as the test suite
  423: improves.
  424: 
  425: =head2 Confidence Levels
  426: 
  427: L<App::Test::Generator::SchemaExtractor> assigns a confidence level
  428: to each extracted schema:
  429: 
  430: =over 4
  431: 
  432: =item * C<high> / C<medium> / C<low> - Schema is used for test generation
  433: 
  434: =item * C<very_low> / C<none> - Falls back to TODO stub
  435: 
  436: =back
  437: 
  438: Confidence is based on how much type and constraint information could
  439: be inferred from the source code and its POD documentation. Methods
  440: with explicit parameter validation (L<Params::Validate::Strict>,
  441: L<Params::Get>) or comprehensive POD will produce higher-confidence
  442: schemas.
  443: 
  444: =head2 Files Produced
  445: 
  446: =over 4
  447: 
  448: =item * C<t/mutant_YYYYMMDD_HHMMSS.t>
  449: 
  450: TODO stub file for all survivors. Committed to the repository by the
  451: GitHub Actions workflow.
  452: 
  453: =item * C<t/conf/mutant_MODNAME_FUNCTION_YYYYMMDD_HHMMSS.yml>
  454: 
  455: Runnable YAML schema for a NUM_BOUNDARY survivor where SchemaExtractor
  456: confidence was sufficient. Picked up by C<t/fuzz.t>.
  457: 
  458: =item * C<t/conf/mutant_fuzz_YYYYMMDD_HHMMSS_FUNCTION.yml>
  459: 
  460: Augmented copy of an existing schema with survivor boundary values
  461: merged in. Picked up by C<t/fuzz.t>.
  462: 
  463: =back
  464: 
  465: =head2 See Also
  466: 
  467: =over 4
  468: 
  469: =item * L<App::Test::Generator::SchemaExtractor> - Schema extraction
  470: from Perl source code
  471: 
  472: =item * L<bin/test-generator-index> - Dashboard generator and
  473: pipeline driver
  474: 
  475: =item * L<bin/generate-test-dashboard> - Full pipeline runner
  476: 
  477: =back
  478: 
  479: =encoding utf8
  480: 
  481: =head1 CONFIGURATION
  482: 
  483: The configuration file,
  484: for each set of tests to be produced,
  485: is a file containing a schema that can be read by L<Config::Abstraction>.
  486: 
  487: =head2 SCHEMA
  488: 
  489: The schema is split into several sections.
  490: 
  491: =head3 C<%input> - input params with keys => type/optional specs
  492: 
  493: When using named parameters
  494: 
  495:   input:
  496:     name:
  497:       type: string
  498:       optional: false
  499:     age:
  500:       type: integer
  501:       optional: true
  502: 
  503: Supported basic types used by the fuzzer: C<string>, C<integer>, C<float>, C<number>, C<boolean>, C<arrayref>, C<hashref>.
  504: See also L<Params::Validate::Strict>.
  505: You can add more custom types using properties.
  506: 
  507: For routines with one unnamed parameter
  508: 
  509:   input:
  510:     type: string
  511: 
  512: For routines with more than one named parameter, use the C<position> keyword.
  513: 
  514:   module: Math::Simple::MinMax
  515:   fuction: max
  516: 
  517:   input:
  518:     left:
  519:       type: number
  520:       position: 0
  521:     right:
  522:       type: number
  523:       position: 1
  524: 
  525:   output:
  526:     type: number
  527: 
  528: The keyword C<undef> is used to indicate that the C<function> takes no arguments.
  529: 
  530: =head3 C<%output> - output param types for L<Return::Set> checking
  531: 
  532:   output:
  533:     type: string
  534: 
  535: If the output hash contains the key _STATUS, and if that key is set to DIES,
  536: the routine should die with the given arguments; otherwise, it should live.
  537: If it's set to WARNS,
  538: the routine should warn with the given arguments.
  539: The output can be set to the string 'undef' if the routine should return the undefined value:
  540: 
  541:   ---
  542:   module: Scalar::Util
  543:   function: blessed
  544: 
  545:   input:
  546:     type: string
  547: 
  548:   output: undef
  549: 
  550: The keyword C<undef> is used to indicate that the C<function> returns nothing.
  551: 
  552: For methods that return a list (rather than a reference), use C<type: array>.
  553: The generated test captures the result in list context and validates it as an
  554: arrayref, which requires L<Test::Returns> 0.03 or later:
  555: 
  556:   output:
  557:     type: array
  558: 
  559: =head3 C<%config> - optional hash of configuration.
  560: 
  561: The current supported variables are
  562: 
  563: =over 4
  564: 
  565: =item * C<close_stdin>
  566: 
  567: Tests should not attempt to read from STDIN (default: 1).
  568: This is ignored on Windows, when never closes STDIN.
  569: 
  570: =item * C<test_nuls>, inject NUL bytes into strings (default: 1)
  571: 
  572: With this test enabled, the function is expected to die when a NUL byte is passed in.
  573: 
  574: =item * C<test_undef>, test with undefined value (default: 1)
  575: 
  576: =item * C<test_empty>, test with empty strings (default: 1)
  577: 
  578: =item * C<test_non_ascii>, test with strings that contain non ascii characters (default: 1)
  579: 
  580: =item * C<timeout>, ensure tests don't hang (default: 10)
  581: 
  582: Setting this to 0 disables timeout testing.
  583: 
  584: =item * C<dedup>, fuzzing can create duplicate tests, go some way to remove duplicates (default: 1)
  585: 
  586: =item * C<properties>, enable L<Test::LectroTest> Property tests (default: 0)
  587: 
  588: *item * C<test_security>, send some security string based tests (default: 0)
  589: 
  590: =back
  591: 
  592: All values default to C<true>.
  593: 
  594: =head3 C<%accessor> - this is an accessor routine
  595: 
  596:   accessor:
  597:     property: ua
  598:     type: getset
  599: 
  600: Has two mandatory elements:
  601: 
  602: =over 4
  603: 
  604: =item * C<property>
  605: 
  606: The name of the property in the object that the routine controls.
  607: 
  608: =item * C<type>
  609: 
  610: One of C<getter>, C<setter>, C<getset>.
  611: 
  612: =back
  613: 
  614: =head3 C<%transforms> - list of transformations from input sets to output sets
  615: 
  616: Transforms allow you to define how input data should be transformed into output data.
  617: This is useful for testing functions that convert between formats, normalize data,
  618: or apply business logic transformations on a set of data to different set of data.
  619: It takes a list of subsets of the input and output definitions,
  620: and verifies that data from each input subset is correctly transformed into data from the matching output subset.
  621: 
  622: =head4 Transform Validation Rules
  623: 
  624: For each transform:
  625: 
  626: =over 4
  627: 
  628: =item 1. Generate test cases using the transform's input schema
  629: 
  630: =item 2. Call the function with those inputs
  631: 
  632: =item 3. Validate the output matches the transform's output schema
  633: 
  634: =item 4. If output has a specific 'value', check exact match
  635: 
  636: =item 5. If output has constraints (min/max), validate within bounds
  637: 
  638: =back
  639: 
  640: =head4 Example 1
  641: 
  642:   ---
  643:   module: builtin
  644:   function: abs
  645: 
  646:   config:
  647:     test_undef: no
  648:     test_empty: no
  649:     test_nuls: no
  650:     test_non_ascii: no
  651: 
  652:   input:
  653:     number:
  654:       type: number
  655:       position: 0
  656: 
  657:   output:
  658:     type: number
  659:     min: 0
  660: 
  661:   transforms:
  662:     positive:
  663:       input:
  664:         number:
  665:           type: number
  666:           position: 0
  667:           min: 0
  668:       output:
  669:         type: number
  670:         min: 0
  671:     negative:
  672:       input:
  673:         number:
  674:           type: number
  675:           position: 0
  676:           max: 0
  677:       output:
  678:         type: number
  679:         min: 0
  680:     error:
  681:       input:
  682:         undef
  683:       output:
  684:         _STATUS: DIES
  685: 
  686: If the output hash contains the key _STATUS, and if that key is set to DIES,
  687: the routine should die with the given arguments; otherwise, it should live.
  688: If it's set to WARNS, the routine should warn with the given arguments.
  689: 
  690: The keyword C<undef> is used to indicate that the C<function> returns nothing.
  691: 
  692: =head4 Example 2
  693: 
  694:   ---
  695:   module: Math::Utils
  696:   function: normalize_number
  697: 
  698:   input:
  699:     value:
  700:       type: number
  701:       position: 0
  702: 
  703:   output:
  704:     type: number
  705: 
  706:   transforms:
  707:     positive_stays_positive:
  708:       input:
  709:         value:
  710:           type: number
  711:           min: 0
  712:           max: 1000
  713:       output:
  714:         type: number
  715:         min: 0
  716:         max: 1
  717: 
  718:     negative_becomes_zero:
  719:       input:
  720:         value:
  721:           type: number
  722:           max: 0
  723:       output:
  724:         type: number
  725:         value: 0
  726: 
  727:     preserves_zero:
  728:       input:
  729:         value:
  730:           type: number
  731:           value: 0
  732:       output:
  733:         type: number
  734:         value: 0
  735: 
  736: =head3 C<$module>
  737: 
  738: The name of the module (optional).
  739: 
  740: Using the reserved word C<builtin> means you're testing a Perl builtin function.
  741: 
  742: If omitted, the generator will guess from the config filename:
  743: C<My-Widget.conf> -> C<My::Widget>.
  744: 
  745: =head3 C<$function>
  746: 
  747: The function/method to test.
  748: 
  749: This defaults to C<run>.
  750: 
  751: =head3 C<%new>
  752: 
  753: An optional hashref of args to pass to the module's constructor.
  754: 
  755:   new:
  756:     api_key: ABC123
  757:     verbose: true
  758: 
  759: To ensure C<new()> is called with no arguments, you still need to define new, thus:
  760: 
  761:   module: MyModule
  762:   function: my_function
  763: 
  764:   new:
  765: 
  766: =head3 C<%cases>
  767: 
  768: An optional Perl static corpus, when the output is a simple string (expected => [ args... ]).
  769: 
  770: Maps the expected output string to the input and _STATUS
  771: 
  772:   cases:
  773:     ok:
  774:       input: ping
  775:       _STATUS: OK
  776:     error:
  777:       input: ""
  778:       _STATUS: DIES
  779: 
  780: =head3 C<$yaml_cases> - optional path to a YAML file with the same shape as C<%cases>.
  781: 
  782: =head3 C<$seed>
  783: 
  784: An optional integer.
  785: When provided, the generated C<t/fuzz.t> will call C<srand($seed)> so fuzz runs are reproducible.
  786: 
  787: =head3 C<$iterations>
  788: 
  789: An optional integer controlling how many fuzz iterations to perform (default 30).
  790: 
  791: =head3 C<%edge_cases>
  792: 
  793: An optional hash mapping of extra values to inject.
  794: 
  795: 	# Two named parameters
  796: 	edge_cases:
  797: 		name: [ '', 'a' x 1024, \"\x{263A}" ]
  798: 		age: [ -1, 0, 99999999 ]
  799: 
  800: 	# Takes a string input
  801: 	edge_cases: [ 'foo', 'bar' ]
  802: 
  803: Values can be strings or numbers; strings will be properly quoted.
  804: Note that this only works with routines that take named parameters.
  805: 
  806: =head3 C<%type_edge_cases>
  807: 
  808: An optional hash mapping types to arrayrefs of extra values to try for any field of that type:
  809: 
  810: 	type_edge_cases:
  811: 		string: [ '', ' ', "\t", "\n", "\0", 'long' x 1024, chr(0x1F600) ]
  812: 		number: [ 0, 1.0, -1.0, 1e308, -1e308, 1e-308, -1e-308, 'NaN', 'Infinity' ]
  813: 		integer: [ 0, 1, -1, 2**31-1, -(2**31), 2**63-1, -(2**63) ]
  814: 
  815: =head3 C<%edge_case_array>
  816: 
  817: Specify edge case values for routines that accept a single unnamed parameter.
  818: This is specifically designed for simple functions that take one argument without a parameter name.
  819: These edge cases supplement the normal random string generation, ensuring specific problematic values are always tested.
  820: 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.
  821: 
  822:   ---
  823:   module: Text::Processor
  824:   function: sanitize
  825: 
  826:   input:
  827:     type: string
  828:     min: 1
  829:     max: 1000
  830: 
  831:   edge_case_array:
  832:     - "<script>alert('xss')</script>"
  833:     - "'; DROP TABLE users; --"
  834:     - "\0null\0byte"
  835:     - "emoji😊test"
  836:     - ""
  837:     - " "
  838: 
  839:   seed: 42
  840:   iterations: 30
  841: 
  842: =head3 Semantic Data Generators
  843: 
  844: For property-based testing with L<Test::LectroTest>,
  845: you can use semantic generators to create realistic test data.
  846: 
  847: C<unix_timestamp> is currently fully supported,
  848: other fuzz testing support for C<semantic> entries is being developed.
  849: 
  850:   input:
  851:     email:
  852:       type: string
  853:       semantic: email
  854: 
  855:     user_id:
  856:       type: string
  857:       semantic: uuid
  858: 
  859:     phone:
  860:       type: string
  861:       semantic: phone_us
  862: 
  863: =head4 Available Semantic Types
  864: 
  865: =over 4
  866: 
  867: =item * C<email> - Valid email addresses (user@domain.tld)
  868: 
  869: =item * C<url> - HTTP/HTTPS URLs
  870: 
  871: =item * C<uuid> - UUIDv4 identifiers
  872: 
  873: =item * C<phone_us> - US phone numbers (XXX-XXX-XXXX)
  874: 
  875: =item * C<phone_e164> - International E.164 format (+XXXXXXXXXXXX)
  876: 
  877: =item * C<ipv4> - IPv4 addresses (0.0.0.0 - 255.255.255.255)
  878: 
  879: =item * C<ipv6> - IPv6 addresses
  880: 
  881: =item * C<username> - Alphanumeric usernames with _ and -
  882: 
  883: =item * C<slug> - URL slugs (lowercase-with-hyphens)
  884: 
  885: =item * C<hex_color> - Hex color codes (#RRGGBB)
  886: 
  887: =item * C<iso_date> - ISO 8601 dates (YYYY-MM-DD)
  888: 
  889: =item * C<iso_datetime> - ISO 8601 datetimes (YYYY-MM-DDTHH:MM:SSZ)
  890: 
  891: =item * C<semver> - Semantic version strings (major.minor.patch)
  892: 
  893: =item * C<jwt> - JWT-like tokens (base64url format)
  894: 
  895: =item * C<json> - Simple JSON objects
  896: 
  897: =item * C<base64> - Base64-encoded strings
  898: 
  899: =item * C<md5> - MD5 hashes (32 hex chars)
  900: 
  901: =item * C<sha256> - SHA-256 hashes (64 hex chars)
  902: 
  903: =item * C<unix_timestamp>
  904: 
  905: =back
  906: 
  907: =head2 EDGE CASE GENERATION
  908: 
  909: In addition to purely random fuzz cases, the harness generates
  910: deterministic edge cases for parameters that declare C<min>, C<max> or C<len> in their schema definitions.
  911: 
  912: For each constraint, three edge cases are added:
  913: 
  914: =over 4
  915: 
  916: =item * Just inside the allowable range
  917: 
  918: This case should succeed, since it lies strictly within the bounds.
  919: 
  920: =item * Exactly on the boundary
  921: 
  922: This case should succeed, since it meets the constraint exactly.
  923: 
  924: =item * Just outside the boundary
  925: 
  926: This case is annotated with C<_STATUS = 'DIES'> in the corpus and
  927: should cause the harness to fail validation or croak.
  928: 
  929: =back
  930: 
  931: Supported constraint types:
  932: 
  933: =over 4
  934: 
  935: =item * C<number>, C<integer>, C<float>
  936: 
  937: Uses numeric values one below, equal to, and one above the boundary.
  938: 
  939: =item * C<string>
  940: 
  941: Uses strings of lengths one below, equal to, and one above the boundary.
  942: 
  943: =item * C<arrayref>
  944: 
  945: Uses references to arrays of with the number of elements one below, equal to, and one above the boundary.
  946: 
  947: =item * C<hashref>
  948: 
  949: Uses hashes with key counts one below, equal to, and one above the
  950: boundary (C<min> = minimum number of keys, C<max> = maximum number
  951: of keys).
  952: 
  953: =item * C<memberof> - arrayref of allowed values for a parameter
  954: 
  955: This example is for a routine called C<input()> that takes two arguments: C<status> and C<level>.
  956: C<status> is a string that must have the value C<ok>, C<error> or C<pending>.
  957: The C<level> argument is an integer that must be one of C<1>, C<5> or C<111>.
  958: 
  959:   ---
  960:   input:
  961:     status:
  962:       type: string
  963:       memberof:
  964:         - ok
  965:         - error
  966:         - pending
  967:     level:
  968:       type: integer
  969:       memberof:
  970:         - 1
  971:         - 5
  972:         - 111
  973: 
  974: The generator will automatically create test cases for each allowed value (inside the member list),
  975: and at least one value outside the list (which should die or C<croak>, C<_STATUS = 'DIES'>).
  976: This works for strings, integers, and numbers.
  977: 
  978: =item * C<enum> - synonym of C<memberof>
  979: 
  980: =item * C<boolean> - automatic boundary tests for boolean fields
  981: 
  982:   input:
  983:     flag:
  984:       type: boolean
  985: 
  986: 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'>.
  987: 
  988: =back
  989: 
  990: These edge cases are inserted automatically, in addition to the random
  991: fuzzing inputs, so each run will reliably probe boundary conditions
  992: without relying solely on randomness.
  993: 
  994: =head1 EXAMPLES
  995: 
  996: See the files in C<t/conf> for examples.
  997: 
  998: =head2 Adding Scheduled fuzz Testing with GitHub Actions to Your Code
  999: 
 1000: To automatically create and run tests on a regular basis on GitHub Actions,
 1001: you need to create a configuration file for each method and subroutine that you're testing,
 1002: and a GitHub Actions configuration file.
 1003: 
 1004: This example takes you through testing the online_render method of L<HTML::Genealogy::Map>.
 1005: 
 1006: =head3 t/conf/online_render.yml
 1007: 
 1008:   ---
 1009: 
 1010:   module: HTML::Genealogy::Map
 1011:   function: onload_render
 1012: 
 1013:   input:
 1014:     gedcom:
 1015:       type: object
 1016:       can: individuals
 1017:     geocoder:
 1018:       type: object
 1019:       can: geocode
 1020:     debug:
 1021:       type: boolean
 1022:       optional: true
 1023:     google_key:
 1024:       type: string
 1025:       optional: true
 1026:       min: 39
 1027:       max: 39
 1028:       matches: "^AIza[0-9A-Za-z_-]{35}$"
 1029: 
 1030:   config:
 1031:     test_undef: 0
 1032: 
 1033: =head3 .github/actions/fuzz.t
 1034: 
 1035:   ---
 1036:   name: Fuzz Testing
 1037: 
 1038:   permissions:
 1039:     contents: read
 1040: 
 1041:   on:
 1042:     push:
 1043:       branches: [main, master]
 1044:     pull_request:
 1045:       branches: [main, master]
 1046:     schedule:
 1047:       - cron: '29 5 14 * *'
 1048: 
 1049:   jobs:
 1050:     generate-fuzz-tests:
 1051:       strategy:
 1052:         fail-fast: false
 1053:         matrix:
 1054:           os:
 1055:             - macos-latest
 1056:             - ubuntu-latest
 1057:             - windows-latest
 1058:           perl: ['5.42', '5.40', '5.38', '5.36', '5.34', '5.32', '5.30', '5.28', '5.22']
 1059: 
 1060:       runs-on: ${{ matrix.os }}
 1061:       name: Fuzz testing with perl ${{ matrix.perl }} on ${{ matrix.os }}
 1062: 
 1063:       steps:
 1064:         - uses: actions/checkout@df4cb1c069e1874edd31b4311f1884172cec0e10 # v6
 1065: 
 1066:         - name: Set up Perl
 1067:           uses: shogo82148/actions-setup-perl@a198315ec4e9244f206879ea7b63078003aec8a6 # v1.41.1
 1068:           with:
 1069:             perl-version: ${{ matrix.perl }}
 1070: 
 1071:         - name: Install App::Test::Generator this module's dependencies
 1072:           run: |
 1073:             cpanm App::Test::Generator
 1074:             cpanm --installdeps .
 1075: 
 1076:         - name: Make Module
 1077:           run: |
 1078:             perl Makefile.PL
 1079:             make
 1080:           env:
 1081:             AUTOMATED_TESTING: 1
 1082:             NONINTERACTIVE_TESTING: 1
 1083: 
 1084:         - name: Generate fuzz tests
 1085:           run: |
 1086:             mkdir t/fuzz
 1087:             find t/conf -name '*.yml' | while read config; do
 1088:               test_name=$(basename "$config" .conf)
 1089:               fuzz-harness-generator "$config" > "t/fuzz/${test_name}_fuzz.t"
 1090:             done
 1091: 
 1092:         - name: Run generated fuzz tests
 1093:           run: |
 1094:             prove -lr t/fuzz/
 1095:           env:
 1096:             AUTOMATED_TESTING: 1
 1097:             NONINTERACTIVE_TESTING: 1
 1098: 
 1099: =head2 Fuzz Testing your CPAN Module
 1100: 
 1101: Running fuzz tests when you run C<make test> in your CPAN module.
 1102: 
 1103: Create a directory <t/conf> which contains the schemas.
 1104: 
 1105: Then create this file as <t/fuzz.t>:
 1106: 
 1107:   #!/usr/bin/env perl
 1108: 
 1109:   use strict;
 1110:   use warnings;
 1111: 
 1112:   use FindBin qw($Bin);
 1113:   use IPC::Run3;
 1114:   use IPC::System::Simple qw(system);
 1115:   use Test::Needs 'App::Test::Generator';
 1116:   use Test::Most;
 1117: 
 1118:   my $dirname = "$Bin/conf";
 1119: 
 1120:   if((-d $dirname) && opendir(my $dh, $dirname)) {
 1121: 	while (my $filename = readdir($dh)) {
 1122: 		# Skip '.' and '..' entries and vi temporary files
 1123: 		next if ($filename eq '.' || $filename eq '..') || ($filename =~ /\.swp$/);
 1124: 
 1125: 		my $filepath = "$dirname/$filename";
 1126: 
 1127: 		if(-f $filepath) {	# Check if it's a regular file
 1128: 			my ($stdout, $stderr);
 1129: 			run3 ['fuzz-harness-generator', '-r', $filepath], undef, \$stdout, \$stderr;
 1130: 
 1131: 			ok($? == 0, 'Generated test script exits successfully');
 1132: 
 1133: 			if($? == 0) {
 1134: 				ok($stdout =~ /^Result: PASS/ms);
 1135: 				if($stdout =~ /Files=1, Tests=(\d+)/ms) {
 1136: 					diag("$1 tests run");
 1137: 				}
 1138: 			} else {
 1139: 				diag("$filepath: STDOUT:\n$stdout");
 1140: 				diag($stderr) if(length($stderr));
 1141: 				diag("$filepath Failed");
 1142: 				last;
 1143: 			}
 1144: 			diag($stderr) if(length($stderr));
 1145: 		}
 1146: 	}
 1147: 	closedir($dh);
 1148:   }
 1149: 
 1150:   done_testing();
 1151: 
 1152: =head2 Property-Based Testing with Transforms
 1153: 
 1154: The generator can create property-based tests using L<Test::LectroTest> when the
 1155: C<properties> configuration option is enabled.
 1156: This provides more comprehensive
 1157: testing by automatically generating thousands of test cases and verifying that
 1158: mathematical properties hold across all inputs.
 1159: 
 1160: =head3 Basic Property-Based Transform Example
 1161: 
 1162: Here's a complete example testing the C<abs> builtin function:
 1163: 
 1164: B<t/conf/abs.yml>:
 1165: 
 1166:   ---
 1167:   module: builtin
 1168:   function: abs
 1169: 
 1170:   config:
 1171:     test_undef: no
 1172:     test_empty: no
 1173:     test_nuls: no
 1174:     properties:
 1175:       enable: true
 1176:       trials: 1000
 1177: 
 1178:   input:
 1179:     number:
 1180:       type: number
 1181:       position: 0
 1182: 
 1183:   output:
 1184:     type: number
 1185:     min: 0
 1186: 
 1187:   transforms:
 1188:     positive:
 1189:       input:
 1190:         number:
 1191:           type: number
 1192:           min: 0
 1193:       output:
 1194:         type: number
 1195:         min: 0
 1196: 
 1197:     negative:
 1198:       input:
 1199:         number:
 1200:           type: number
 1201:           max: 0
 1202:       output:
 1203:         type: number
 1204:         min: 0
 1205: 
 1206: This configuration:
 1207: 
 1208: =over 4
 1209: 
 1210: =item * Enables property-based testing with 1000 trials per property
 1211: 
 1212: =item * Defines two transforms: one for positive numbers, one for negative
 1213: 
 1214: =item * Automatically generates properties that verify C<abs()> always returns non-negative numbers
 1215: 
 1216: =back
 1217: 
 1218: Generate the test:
 1219: 
 1220:   fuzz-harness-generator t/conf/abs.yml > t/abs_property.t
 1221: 
 1222: The generated test will include:
 1223: 
 1224: =over 4
 1225: 
 1226: =item * Traditional edge-case tests for boundary conditions
 1227: 
 1228: =item * Random fuzzing with 30 iterations (or as configured)
 1229: 
 1230: =item * Property-based tests that verify the transforms with 1000 trials each
 1231: 
 1232: =back
 1233: 
 1234: =head3 What Properties Are Tested?
 1235: 
 1236: The generator automatically detects and tests these properties based on your transform specifications:
 1237: 
 1238: =over 4
 1239: 
 1240: =item * B<Range constraints> - If output has C<min> or C<max>, verifies results stay within bounds
 1241: 
 1242: =item * B<Type preservation> - Ensures numeric inputs produce numeric outputs
 1243: 
 1244: =item * B<Definedness> - Verifies the function doesn't return C<undef> unexpectedly
 1245: 
 1246: =item * B<Specific values> - If output specifies a C<value>, checks exact equality
 1247: 
 1248: =back
 1249: 
 1250: For the C<abs> example above, the generated properties verify:
 1251: 
 1252:   # For the "positive" transform:
 1253:   - Given a positive number, abs() returns >= 0
 1254:   - The result is a valid number
 1255:   - The result is defined
 1256: 
 1257:   # For the "negative" transform:
 1258:   - Given a negative number, abs() returns >= 0
 1259:   - The result is a valid number
 1260:   - The result is defined
 1261: 
 1262: =head3 Advanced Example: String Normalization
 1263: 
 1264: Here's a more complex example testing a string normalization function:
 1265: 
 1266: B<t/conf/normalize.yml>:
 1267: 
 1268:   ---
 1269:   module: Text::Processor
 1270:   function: normalize_whitespace
 1271: 
 1272:   config:
 1273:     properties:
 1274:       enable: true
 1275:       trials: 500
 1276: 
 1277:   input:
 1278:     text:
 1279:       type: string
 1280:       min: 0
 1281:       max: 1000
 1282:       position: 0
 1283: 
 1284:   output:
 1285:     type: string
 1286:     min: 0
 1287:     max: 1000
 1288: 
 1289:   transforms:
 1290:     empty_preserved:
 1291:       input:
 1292:         text:
 1293:           type: string
 1294:           value: ""
 1295:       output:
 1296:         type: string
 1297:         value: ""
 1298: 
 1299:     single_space:
 1300:       input:
 1301:         text:
 1302:           type: string
 1303:           min: 1
 1304:           matches: '^\S+(\s+\S+)*$'
 1305:       output:
 1306:         type: string
 1307:         matches: '^\S+( \S+)*$'
 1308: 
 1309:     length_bounded:
 1310:       input:
 1311:         text:
 1312:           type: string
 1313:           min: 1
 1314:           max: 100
 1315:       output:
 1316:         type: string
 1317:         min: 1
 1318:         max: 100
 1319: 
 1320: This tests that the normalization function:
 1321: 
 1322: =over 4
 1323: 
 1324: =item * Preserves empty strings (C<empty_preserved> transform)
 1325: 
 1326: =item * Collapses multiple spaces into single spaces (C<single_space> transform)
 1327: 
 1328: =item * Maintains length constraints (C<length_bounded> transform)
 1329: 
 1330: =back
 1331: 
 1332: =head3 Interpreting Property Test Results
 1333: 
 1334: When property-based tests run, you'll see output like:
 1335: 
 1336:   ok 123 - negative property holds (1000 trials)
 1337:   ok 124 - positive property holds (1000 trials)
 1338: 
 1339: If a property fails, Test::LectroTest will attempt to find the minimal failing
 1340: case and display it:
 1341: 
 1342:   not ok 123 - positive property holds (47 trials)
 1343:   # Property failed
 1344:   # Reason: counterexample found
 1345: 
 1346: This helps you quickly identify edge cases that your function doesn't handle correctly.
 1347: 
 1348: =head3 Configuration Options for Property-Based Testing
 1349: 
 1350: In the C<config> section:
 1351: 
 1352:   config:
 1353:     properties:
 1354:       enable: true     # Enable property-based testing (default: false)
 1355:       trials: 1000     # Number of test cases per property (default: 1000)
 1356: 
 1357: You can also disable traditional fuzzing and only use property-based tests:
 1358: 
 1359:   config:
 1360:     properties:
 1361:       enable: true
 1362:       trials: 5000
 1363: 
 1364:   iterations: 0  # Disable random fuzzing, use only property tests
 1365: 
 1366: =head3 When to Use Property-Based Testing
 1367: 
 1368: Property-based testing with transforms is particularly useful for:
 1369: 
 1370: =over 4
 1371: 
 1372: =item * Mathematical functions (C<abs>, C<sqrt>, C<min>, C<max>, etc.)
 1373: 
 1374: =item * Data transformations (encoding, normalization, sanitization)
 1375: 
 1376: =item * Parsers and formatters
 1377: 
 1378: =item * Functions with clear input-output relationships
 1379: 
 1380: =item * Code that should satisfy mathematical properties (commutativity, associativity, idempotence)
 1381: 
 1382: =back
 1383: 
 1384: =head3 Requirements
 1385: 
 1386: Property-based testing requires both L<Test::LectroTest> and
 1387: L<Test::LectroTest::Compat> to be installed:
 1388: 
 1389:   cpanm Test::LectroTest Test::LectroTest::Compat
 1390: 
 1391: L<Test::LectroTest::Compat> provides the C<use_ok> bridge between
 1392: L<Test::LectroTest> and L<Test::Most>; it is used in every generated
 1393: property-based test file.  Both are declared in the distribution's
 1394: C<TEST_REQUIRES> so they are installed automatically during C<make test>.
 1395: 
 1396: If not installed, the generated tests will automatically skip the property-based
 1397: portion with a message.
 1398: 
 1399: =head3 Testing Email Validation
 1400: 
 1401:   ---
 1402:   module: Email::Valid
 1403:   function: rfc822
 1404: 
 1405:   config:
 1406:     properties:
 1407:       enable: true
 1408:       trials: 200
 1409:     close_stdin: true
 1410:     test_undef: no
 1411:     test_empty: no
 1412:     test_nuls: no
 1413: 
 1414:   input:
 1415:     email:
 1416:       type: string
 1417:       semantic: email
 1418:       position: 0
 1419: 
 1420:   output:
 1421:     type: boolean
 1422: 
 1423:   transforms:
 1424:     valid_emails:
 1425:       input:
 1426:         email:
 1427:           type: string
 1428:           semantic: email
 1429:       output:
 1430:         type: boolean
 1431: 
 1432: This generates 200 realistic email addresses for testing, rather than random strings.
 1433: 
 1434: =head3 Combining Semantic with Regex
 1435: 
 1436: You can combine semantic generators with regex validation:
 1437: 
 1438:   input:
 1439:     corporate_email:
 1440:       type: string
 1441:       semantic: email
 1442:       matches: '@company\.com$'
 1443: 
 1444: The semantic generator creates realistic emails, and the regex ensures they match your domain.
 1445: 
 1446: =head3 Custom Properties for Transforms
 1447: 
 1448: You can define additional properties that should hold for your transforms beyond
 1449: the automatically detected ones.
 1450: 
 1451: =head4 Using Built-in Properties
 1452: 
 1453:   transforms:
 1454:     positive:
 1455:       input:
 1456:         number:
 1457:           type: number
 1458:           min: 0
 1459:       output:
 1460:         type: number
 1461:         min: 0
 1462:       properties:
 1463:         - idempotent       # f(f(x)) == f(x)
 1464:         - non_negative     # result >= 0
 1465:         - positive         # result > 0
 1466: 
 1467: Available built-in properties:
 1468: 
 1469: =over 4
 1470: 
 1471: =item * C<idempotent> - Function is idempotent: f(f(x)) == f(x)
 1472: 
 1473: =item * C<non_negative> - Result is always >= 0
 1474: 
 1475: =item * C<positive> - Result is always > 0
 1476: 
 1477: =item * C<non_empty> - String result is never empty
 1478: 
 1479: =item * C<length_preserved> - Output length equals input length
 1480: 
 1481: =item * C<uppercase> - Result is all uppercase
 1482: 
 1483: =item * C<lowercase> - Result is all lowercase
 1484: 
 1485: =item * C<trimmed> - No leading/trailing whitespace
 1486: 
 1487: =item * C<sorted_ascending> - Array is sorted ascending
 1488: 
 1489: =item * C<sorted_descending> - Array is sorted descending
 1490: 
 1491: =item * C<unique_elements> - Array has no duplicates
 1492: 
 1493: =item * C<preserves_keys> - Hash has same keys as input
 1494: 
 1495: =back
 1496: 
 1497: =head4 Custom Property Code
 1498: 
 1499: Custom properties allows the definition additional invariants and relationships that should hold for their transforms,
 1500: beyond what's auto-detected.
 1501: For example:
 1502: 
 1503: =over 4
 1504: 
 1505: =item * Idempotence: f(f(x)) == f(x)
 1506: 
 1507: =item * Commutativity: f(x, y) == f(y, x)
 1508: 
 1509: =item * Associativity: f(f(x, y), z) == f(x, f(y, z))
 1510: 
 1511: =item * Inverse relationships: decode(encode(x)) == x
 1512: 
 1513: =item * Domain-specific invariants: Custom business logic
 1514: 
 1515: =back
 1516: 
 1517: Define your own properties with custom Perl code:
 1518: 
 1519:   transforms:
 1520:     normalize:
 1521:       input:
 1522:         text:
 1523:           type: string
 1524:       output:
 1525:         type: string
 1526:       properties:
 1527:         - name: single_spaces
 1528:           description: "No multiple consecutive spaces"
 1529:           code: $result !~ /  /
 1530: 
 1531:         - name: no_leading_space
 1532:           description: "No space at start"
 1533:           code: $result !~ /^\s/
 1534: 
 1535:         - name: reversible
 1536:           description: "Can be reversed back"
 1537:           code: length($result) == length($text)
 1538: 
 1539: The code has access to:
 1540: 
 1541: =over 4
 1542: 
 1543: =item * C<$result> - The function's return value
 1544: 
 1545: =item * Input variables - All input parameters (e.g., C<$text>, C<$number>)
 1546: 
 1547: =item * The function itself - Can call it again for idempotence checks
 1548: 
 1549: =back
 1550: 
 1551: =head4 Combining Auto-detected and Custom Properties
 1552: 
 1553: The generator automatically detects properties from your output spec, and adds
 1554: your custom properties:
 1555: 
 1556:   transforms:
 1557:     sanitize:
 1558:       input:
 1559:         html:
 1560:           type: string
 1561:       output:
 1562:         type: string
 1563:         min: 0              # Auto-detects: defined, min_length >= 0
 1564:         max: 10000
 1565:       properties:           # Additional custom checks:
 1566:         - name: no_scripts
 1567:           code: $result !~ /<script/i
 1568:         - name: no_iframes
 1569:           code: $result !~ /<iframe/i
 1570: 
 1571: =head2 GENERATED OUTPUT
 1572: 
 1573: The generated test:
 1574: 
 1575: =over 4
 1576: 
 1577: =item * Seeds RND (if configured) for reproducible fuzz runs
 1578: 
 1579: =item * Uses edge cases (per-field and per-type) with configurable probability
 1580: 
 1581: =item * Runs C<$iterations> fuzz cases plus appended edge-case runs
 1582: 
 1583: =item * Validates inputs with Params::Get / Params::Validate::Strict
 1584: 
 1585: =item * Validates outputs with L<Return::Set>
 1586: 
 1587: =item * Runs static C<is(... )> corpus tests from Perl and/or YAML corpus
 1588: 
 1589: =item * Runs L<Test::LectroTest> tests
 1590: 
 1591: =back
 1592: 
 1593: =cut
 1594: 
 1595: =head1 METHODS
 1596: 
 1597: =head2 generate
 1598: 
 1599: Takes a schema file and produces a test file (or STDOUT).
 1600: 
 1601:   # Modern named API
 1602:   App::Test::Generator->generate(
 1603:       schema_file => 'schemas/foo.yml',
 1604:       output_file => 'test/foo.t',
 1605:   );
 1606: 
 1607:   # Legacy positional API
 1608:   App::Test::Generator->generate($schema_file, $test_file);
 1609: 
 1610: =head3 API Specification
 1611: 
 1612: =head4 Input
 1613: 
 1614:     {
 1615:         schema_file => { type => 'string', optional => 0 },
 1616:         input_file  => { type => 'string', optional => 1 },
 1617:         output_file => { type => 'string', optional => 1, max => 255 },
 1618:     }
 1619: 
 1620: =head4 Output
 1621: 
 1622:     { type => 'string' }
 1623: 
 1624: =cut
 1625: 
 1626: sub generate
 1627: {
●1628 → 1640 → 1676 1628: 	croak 'Usage: generate(schema_file [, outfile])' if(scalar(@_) == 0);
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1629: 
 1630: 	# Accept both class-method call (App::Test::Generator->generate(...))
 1631: 	# and plain-function call with a hashref (generate({...})).
 1632: 	# In the method form the first arg is the class name (a plain string);
 1633: 	# in the function form with a hashref the first arg IS the hashref.
 1634: 	my $class = (ref($_[0]) ne 'HASH') ? shift : undef;
 1635: 	my ($schema_file, $test_file, $schema);
 1636: 	# Globals loaded from the user's conf (all optional except function maybe)
 1637: 	my ($module, $function, $new, $yaml_cases);
 1638: 	my ($seed, $iterations);
 1639: 
 1640: 	if((ref($_[0]) eq 'HASH') || defined($_[2])) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1641: 		# Modern API
 1642: 		my $params = Params::Validate::Strict::validate_strict({
 1643: 			args => Params::Get::get_params(undef, \@_),
 1644: 			schema => {
 1645: 				input_file => { type => 'string', optional => 1 },
 1646: 				schema_file => { type => 'string', optional => 1 },
 1647: 				output_file => { type => 'string', optional => 1 },
 1648: 				schema => { type => 'hashref', optional => 1 },
 1649: 				quiet => { type => 'boolean', optional => 1 },	# Not yet used
 1650: 			}
 1651: 		});
 1652: 		if($params->{'schema_file'}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1653: 			$schema_file = $params->{'schema_file'};
 1654: 		} elsif($params->{'input_file'}) {
 1655: 			$schema_file = $params->{'input_file'};
 1656: 		} elsif($params->{'schema'}) {
 1657: 			$schema = $params->{'schema'};
 1658: 		} else {
 1659: 			croak(__PACKAGE__, ': Usage: generate(input_file|schema [, output_file]');
 1660: 		}
 1661: 		if(defined($schema_file)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1662: 			$schema = _load_schema($schema_file);
 1663: 		}
 1664: 		$test_file = $params->{'output_file'};
 1665: 	} else {
 1666: 		# Legacy API
 1667: 		($schema_file, $test_file) = @_;
 1668: 		if(defined($schema_file)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1669: 			$schema = _load_schema($schema_file);
 1670: 		} else {
 1671: 			croak 'Usage: generate(schema_file [, outfile])';
 1672: 		}
 1673: 	}
 1674: 
 1675: 	# Parse the schema file and load into our structures
●1676 → 1687 → 1690 1676: 	my %input = %{_load_schema_section($schema, 'input', $schema_file)};
 1677: 	my %output = %{_load_schema_section($schema, 'output', $schema_file)};
 1678: 	my %transforms = %{_load_schema_section($schema, 'transforms', $schema_file)};
 1679: 	my %accessor = %{_load_schema_section($schema, 'accessor', $schema_file)};
 1680: 
 1681: 	my %cases = %{$schema->{cases}} if(exists($schema->{cases}));
 1682: 	my %edge_cases = %{$schema->{edge_cases}} if(exists($schema->{edge_cases}));
 1683: 	my %type_edge_cases = %{$schema->{type_edge_cases}} if(exists($schema->{type_edge_cases}));
 1684: 
 1685: 	$module = $schema->{module} if(exists($schema->{module}) && length($schema->{module}));
 1686: 	$function = $schema->{function} if(exists($schema->{function}));
 1687: 	if(exists($schema->{new})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1688: 		$new = defined($schema->{'new'}) ? $schema->{new} : '_UNDEF';
 1689: 	}
●1690 → 1702 → 1716 1690: 	$yaml_cases = $schema->{yaml_cases} if(exists($schema->{yaml_cases}));
 1691: 	$seed = $schema->{seed} if(exists($schema->{seed}));
 1692: 	$iterations = $schema->{iterations} if(exists($schema->{iterations}));
 1693: 
 1694: 	my @edge_case_array = @{$schema->{edge_case_array}} if(exists($schema->{edge_case_array}));
 1695: 	_validate_config($schema);
 1696: 
 1697: 	my %config = %{$schema->{config}} if(exists($schema->{config}));
 1698: 
 1699: 	_normalize_config(\%config);
 1700: 
 1701: 	# Guess module name from config file if not set
 1702: 	if(!$module) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1703: 		if($schema_file) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1704: 			($module = basename($schema_file)) =~ s/\.(conf|pl|pm|yml|yaml)$//;
 1705: 			$module =~ s/-/::/g;
 1706: 			# Guard against Perl builtin function names being mistaken
 1707: 			# for module names — builtins have no module to load
 1708: 			if(_is_perl_builtin($module)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1709: 				undef $module;
 1710: 			}
 1711: 		}
 1712: 	} elsif($module eq $MODULE_BUILTIN) {
 1713: 		undef $module;
 1714: 	}
 1715: 
●1716 → 1716 → 1723 1716: 	if($module && length($module) && ($module ne 'builtin')) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1717: 		_validate_module($module, $schema_file);
 1718: 	}
 1719: 
 1720: 	# $module/$function are spliced unescaped into generated test
 1721: 	# source below (use_ok, new_ok, ->$function, $module::$function)
 1722: 	# — reject anything that isn't identifier-shaped before that happens.
●1723 → 1736 → 1757 1723: 	_assert_identifier($module, 'module', package => 1) if defined($module) && length($module);
 1724: 
 1725: 	# sensible defaults
 1726: 	$function ||= 'run';
 1727: 	# package => 1: fully-qualified sub names (e.g. DB::DB, a debugger
 1728: 	# hook installed into the DB:: package regardless of its source
 1729: 	# package) are legitimate function names, not just bare identifiers
 1730: 	_assert_identifier($function, 'function', package => 1);
 1731: 	$iterations ||= $DEFAULT_ITERATIONS;		 # default fuzz runs if not specified
 1732: 	$seed = undef if defined $seed && $seed eq '';	# treat empty as undef
 1733: 
 1734: 	# --- YAML corpus support (yaml_cases is filename string) ---
 1735: 	my %yaml_corpus_data;
 1736: 	if (defined $yaml_cases) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1737: 		croak("$yaml_cases: $!") if(!-f $yaml_cases);
 1738: 
 1739: 		my $yaml_data = LoadFile(Encode::decode('utf8', $yaml_cases));
 1740: 		if ($yaml_data && ref($yaml_data) eq 'HASH') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1741: 			# Validate that the corpus inputs are arrayrefs
 1742: 			# e.g: "FooBar": 	["foo_bar"]
 1743: 			# Skip only invalid entries:
 1744: 			for my $expected (keys %{$yaml_data}) {
 1745: 				my $outputs = $yaml_data->{$expected};
 1746: 				unless($outputs && (ref $outputs eq 'ARRAY')) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1747: 					carp("$yaml_cases: $expected does not point to an array ref, ignoring");
 1748: 					next;
 1749: 				}
 1750: 				$yaml_corpus_data{$expected} = $outputs;
 1751: 			}
 1752: 		}
 1753: 	}
 1754: 
 1755: 	# Merge Perl %cases and YAML corpus safely
 1756: 	# my %all_cases = (%cases, %yaml_corpus_data);
●1757 → 1758 → 1764 1757: 	my %all_cases = (%yaml_corpus_data, %cases);
 1758: 	for my $k (keys %yaml_corpus_data) {
 1759: 		if (exists $cases{$k} && ref($cases{$k}) eq 'ARRAY' && ref($yaml_corpus_data{$k}) eq 'ARRAY') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1760: 			$all_cases{$k} = [ @{$yaml_corpus_data{$k}}, @{$cases{$k}} ];
 1761: 		}
 1762: 	}
 1763: 
●1764 → 1764 → 1774 1764: 	if(my $hints = delete $schema->{_yamltest_hints}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1765: 		if(my $boundaries = $hints->{boundary_values}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1766: 			push @edge_case_array, @{$boundaries};
 1767: 		}
 1768: 		if(my $invalid = $hints->{invalid}) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_1768_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 1769: 			carp('TODO: handle yamltest_hints->invalid');
 1770: 		}
 1771: 	}
 1772: 
 1773: 	# If the schema says the type is numeric, normalize
●1774 → 1774 → 1784 1774: 	if ($schema->{type} && $schema->{type} =~ /^(integer|number|float)$/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1775: 		for (@edge_case_array) {
 1776: 			next unless defined $_;
 1777: 			$_ += 0 if Scalar::Util::looks_like_number($_);
 1778: 		}
 1779: 	}
 1780: 
 1781: 	# Load relationships from the schema if present and well-formed.
 1782: 	# SchemaExtractor may set this to undef or an empty arrayref when
 1783: 	# no relationships were detected, so guard both existence and type.
●1784 → 1785 → 1793 1784: 	my @relationships;
 1785: 	if(exists($schema->{relationships}) && ref($schema->{relationships}) eq 'ARRAY') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1786: 		@relationships = @{$schema->{relationships}};
 1787: 	}
 1788: 
 1789: 	# Serialise the relationships array from the schema into Perl source
 1790: 	# code for embedding in the generated test file. Each relationship
 1791: 	# type is rendered as a hashref in the @relationships array.
 1792: 
●1793 → 1796 → 1845 1793: 	my $relationships_code = '';
 1794: 
 1795: 	# Walk each relationship in the order SchemaExtractor produced them
 1796: 	for my $rel (@relationships) {
 1797: 		my $type = $rel->{type} // '';
 1798: 
 1799: 		# Mutually exclusive: both params being set should cause the method to die
 1800: 		if($type eq 'mutually_exclusive') {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_1800_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 1801: 			$relationships_code .= "{ type => 'mutually_exclusive', params => [" .
 1802: 				join(', ', map { perl_quote($_) } @{$rel->{params}}) .
 1803: 				"] },\n";
 1804: 
 1805: 		# Required group: at least one of the params must be present
 1806: 		} elsif($type eq 'required_group') {
 1807: 			$relationships_code .= "{ type => 'required_group', params => [" .
 1808: 				join(', ', map { perl_quote($_) } @{$rel->{params}}) .
 1809: 				"], logic => " . perl_quote($rel->{logic} // 'or') . " },\n";
 1810: 
 1811: 		# Conditional requirement: if one param is set, another becomes mandatory
 1812: 		} elsif($type eq 'conditional_requirement') {
 1813: 			$relationships_code .= "{ type => 'conditional_requirement', if => " .
 1814: 				perl_quote($rel->{'if'}) . ", then_required => " .
 1815: 				perl_quote($rel->{then_required}) . " },\n";
 1816: 
 1817: 		# Dependency: one param requires another to also be present
 1818: 		} elsif($type eq 'dependency') {
 1819: 			$relationships_code .= "{ type => 'dependency', param => " .
 1820: 				perl_quote($rel->{param}) . ", requires => " .
 1821: 				perl_quote($rel->{requires}) . " },\n";
 1822: 
 1823: 		# Value constraint: one param being set forces another to a specific value
 1824: 		} elsif($type eq 'value_constraint') {
 1825: 			$relationships_code .= "{ type => 'value_constraint', if => " .
 1826: 				perl_quote($rel->{'if'}) . ", then => " .
 1827: 				perl_quote($rel->{then}) . ", operator => " .
 1828: 				perl_quote($rel->{operator}) . ", value => " .
 1829: 				perl_quote($rel->{value}) . " },\n";
 1830: 
 1831: 		# Value conditional: one param equalling a specific value requires another param
 1832: 		} elsif($type eq 'value_conditional') {
 1833: 			$relationships_code .= "{ type => 'value_conditional', if => " .
 1834: 				perl_quote($rel->{'if'}) . ", equals => " .
 1835: 				perl_quote($rel->{equals}) . ", then_required => " .
 1836: 				perl_quote($rel->{then_required}) . " },\n";
 1837: 
 1838: 		# Unknown type — warn and skip rather than emitting broken code
 1839: 		} else {
 1840: 			carp "Unknown relationship type '$type', skipping";
 1841: 		}
 1842: 	}
 1843: 
 1844: 	# Dedup the edge cases
●1845 → 1870 → 1875 1845: 	my %seen;
 1846: 	@edge_case_array = grep {
 1847: 		my $key = defined($_) ? (Scalar::Util::looks_like_number($_) ? "N:$_" : "S:$_") : 'U';
 1848: 		!$seen{$key}++;
 1849: 	} @edge_case_array;
 1850: 
 1851: 	# Sort the edge cases to keep it consistent across runs
 1852: 	@edge_case_array = sort {
 1853: 		return -1 if !defined $a;

					

					
Mutants (Total: 2, Killed: 0, Survived: 2)
					

				
BOOL_NEGATE_1853_3: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes

								

								
🧪 Suggested Test
								
# Boolean branch test suggestion
ok( !func(INPUT), 'Verify boolean branch behaviour' );

								
							
RETURN_UNDEF_1853_3: Replace return expression with undef
LOW: Mutation survived, but impact may be minor

								

								
🧪 Suggested Test
								
# Return value assertion
is( func(INPUT), EXPECTED, 'Verify correct return value' );

								
							
 1854: 		return 1 if !defined $b;

					

					
Mutants (Total: 2, Killed: 0, Survived: 2)
					

				
BOOL_NEGATE_1854_3: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes

								

								
🧪 Suggested Test
								
# Boolean branch test suggestion
ok( !func(INPUT), 'Verify boolean branch behaviour' );

								
							
RETURN_UNDEF_1854_3: Replace return expression with undef
LOW: Mutation survived, but impact may be minor

								

								
🧪 Suggested Test
								
# Return value assertion
is( func(INPUT), EXPECTED, 'Verify correct return value' );

								
							
 1855: 
 1856: 		my $na = Scalar::Util::looks_like_number($a);
 1857: 		my $nb = Scalar::Util::looks_like_number($b);
 1858: 
 1859: 		return $a <=> $b if $na && $nb;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 1860: 		return -1 if $na;

					

					
Mutants (Total: 2, Killed: 0, Survived: 2)
					

				
BOOL_NEGATE_1860_3: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes

								

								
🧪 Suggested Test
								
# Boolean branch test suggestion
ok( !func(INPUT), 'Verify boolean branch behaviour' );

								
							
RETURN_UNDEF_1860_3: Replace return expression with undef
LOW: Mutation survived, but impact may be minor

								

								
🧪 Suggested Test
								
# Return value assertion
is( func(INPUT), EXPECTED, 'Verify correct return value' );

								
							
 1861: 		return 1 if $nb;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 1862: 		return $a cmp $b;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 1863: 	} @edge_case_array;
 1864: 
 1865: 	# render edge case maps for inclusion in the .t
 1866: 	my $edge_cases_code = render_arrayref_map(\%edge_cases);
 1867: 	my $type_edge_cases_code = render_arrayref_map(\%type_edge_cases);
 1868: 
 1869: 	my $edge_case_array_code = '';
 1870: 	if(scalar(@edge_case_array)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1871: 		$edge_case_array_code = join(', ', map { q_wrap($_) } @edge_case_array);
 1872: 	}
 1873: 
 1874: 	# Render configuration - all the values are integers for now, if that changes, wrap the $config{$key} in single quotes
●1875 → 1876 → 1892 1875: 	my $config_code = '';
 1876: 	foreach my $key (sort keys %config) {
 1877: 		# Skip nested structures like 'properties' - they're used during
 1878: 		# generation but don't need to be in the generated test
 1879: 		if(ref($config{$key}) eq 'HASH') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1880: 			next;
 1881: 		}
 1882: 		if((!defined($config{$key})) || !$config{$key}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1883: 			# YAML will strip the word 'false'
 1884: 			# e.g. in 'test_undef: false'
 1885: 			$config_code .= "'$key' => 0,\n";
 1886: 		} else {
 1887: 			$config_code .= "'$key' => $config{$key},\n";
 1888: 		}
 1889: 	}
 1890: 
 1891: 	# Render input/output
●1892 → 1893 → 1902 1892: 	my $input_code = '';
 1893: 	if(((scalar keys %input) == 1) && exists($input{'type'}) && !ref($input{'type'})) {

					

					
Mutants (Total: 2, Killed: 0, Survived: 2)
					

				
NUM_BOUNDARY_1893_27_!=: Numeric boundary flip == to !=
HIGH: Likely missing edge-case test (boundary value)

								

								
🧪 Suggested Test
								
# Boundary test suggestion
is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );

								
							
COND_INV_1893_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 1894: 		# %input = ( type => 'string' );
 1895: 		foreach my $key (sort keys %input) {
 1896: 			$input_code .= "'$key' => '$input{$key}',\n";
 1897: 		}
 1898: 	} else {
 1899: 		# %input = ( str => { type => 'string' } );
 1900: 		$input_code = render_hash(\%input);
 1901: 	}
●1902 → 1902 → 1919 1902: 	if(defined(my $re = $output{'matches'})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1903: 		if(ref($re) ne 'Regexp') {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_1903_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 1904: 			# Use eval to compile safely — qr/$re/ would interpolate
 1905: 			# the string first, corrupting patterns containing [ or \
 1906: 			my $compiled = eval { qr/$re/ };
 1907: 			if($@) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_1907_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 1908: 				carp("Invalid matches pattern '$re': $@");
 1909: 			} else {
 1910: 				$output{'matches'} = $compiled;
 1911: 			}
 1912: 		}
 1913: 	}
 1914: 
 1915: 	# Compile nomatch pattern to a Regexp object so it renders
 1916: 	# as qr{} in the generated test rather than a raw string.
 1917: 	# Without this, patterns containing [ or other regex
 1918: 	# metacharacters cause compilation failures in validators
●1919 → 1919 → 1932 1919: 	if(defined(my $re = $output{'nomatch'})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1920: 		if(ref($re) ne 'Regexp') {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_1920_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 1921: 			# Use eval to compile safely — qr/$re/ would interpolate
 1922: 			# the string first, corrupting patterns containing [ or \
 1923: 			my $compiled = eval { qr/$re/ };
 1924: 			if($@) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_1924_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 1925: 				carp("Invalid nomatch pattern '$re': $@");
 1926: 			} else {
 1927: 				$output{'nomatch'} = $compiled;
 1928: 			}
 1929: 		}
 1930: 	}
 1931: 
●1932 → 1936 → 1954 1932: 	my $output_code = render_args_hash(\%output);
 1933: 	my $new_code = ($new && (ref $new eq 'HASH')) ? render_args_hash($new) : '';
 1934: 
 1935: 	my $transforms_code;
 1936: 	if(keys %transforms) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1937: 		foreach my $transform(keys %transforms) {
 1938: 			my $properties = render_fallback($transforms{$transform}->{'properties'});
 1939: 
 1940: 			if($transforms_code) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_1940_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 1941: 				$transforms_code .= "},\n";
 1942: 			}
 1943: 			$transforms_code .= "$transform => {\n" .
 1944: 				"\t'input' => { " .
 1945: 				render_args_hash($transforms{$transform}->{'input'}) .
 1946: 				"\t}, 'output' => { " .
 1947: 				render_args_hash($transforms{$transform}->{'output'}) .
 1948: 				"\t}, 'properties' => $properties\n" .
 1949: 				"\t,\n";
 1950: 		}
 1951: 		$transforms_code .= "}\n";
 1952: 	}
 1953: 
●1954 → 1957 → 1974 1954: 	my $transform_properties_code = '';
 1955: 	my $use_properties = 0;
 1956: 
 1957: 	if (keys %transforms && ($config{properties}{enable} // 0)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1958: 		$use_properties = 1;
 1959: 
 1960: 		# Generate property-based tests for transforms
 1961: 		my $properties = _generate_transform_properties(
 1962: 			\%transforms,
 1963: 			$function,
 1964: 			$module,
 1965: 			\%input,
 1966: 			\%config,
 1967: 			$new
 1968: 		);
 1969: 
 1970: 		# Convert to code for template
 1971: 		$transform_properties_code = _render_properties($properties);
 1972: 	}
 1973: 
●1974 → 1974 → 1995 1974: 	if(keys %accessor) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1975: 		# Sanity test
 1976: 		my $property = $accessor{property};
 1977: 		my $type = $accessor{type};
 1978: 
 1979: 		if(!defined($new)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1980: 			# Internal invariant — schema has a contradictory accessor+type combination;
 1981: 			# confess gives the full call chain to aid debugging
 1982: 			confess("invariant violation: $property: accessor $type can only work on an object, incorrectly tagged as $type");
 1983: 		}
 1984: 		if($type eq 'getset') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1985: 			if(scalar(keys %input) != 1) {
  Mutants (Total: 2, Killed: 2, Survived: 0)
 1986: 				confess("invariant violation: $property: getset must take one input argument, incorrectly tagged as getset");
 1987: 			}
 1988: 			if(scalar(keys %output) == 0) {
  Mutants (Total: 2, Killed: 2, Survived: 0)
 1989: 				confess("invariant violation: $property: getset must give one output, incorrectly tagged as getset");
 1990: 			}
 1991: 		}
 1992: 	}
 1993: 
 1994: 	# Setup / call code (always load module)
●1995 → 1999 → 2067 1995: 	my $setup_code = ($module) ? "BEGIN { use_ok('$module') }" : '';
 1996: 	my $call_code;	# Code to call the function being test when used with named arguments
 1997: 	my $position_code;	# Code to call the function being test when used with position arguments
 1998: 	my $has_positions = _has_positions(\%input);
 1999: 	if(defined($new) && defined($module)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2000: 		# keep use_ok regardless (user found earlier issue)
 2001: 		if($new_code eq '') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2002: 			$new_code = "new_ok('$module')";
 2003: 		} else {
 2004: 			$new_code = "new_ok('$module' => [ { $new_code } ] )";
 2005: 		}
 2006: 		$setup_code .= "\nmy \$obj = $new_code;";
 2007: 		if($has_positions) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2007_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2008: 			$position_code = "\$result = (scalar(\@alist) == 1) ? \$obj->$function(\$alist[0]) : (scalar(\@alist) == 0) ? \$obj->$function() : \$obj->$function(\@alist);";
 2009: 			if(defined($accessor{type})) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2009_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2010: 				if($accessor{type} eq 'getter') {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2010_5: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2011: 					$position_code .= "my \$prev_value = \$obj->{$accessor{property}};";
 2012: 				} elsif($accessor{type} eq 'getset') {
 2013: 					$position_code .= 'if(scalar(@alist) == 1) { ';
 2014: 					$position_code .= "cmp_ok(\$result, 'eq', \$alist[0], 'getset function returns what was put in'); ok(\$obj->$function() eq \$result, 'test getset accessor');";
 2015: 					$position_code .= '}';
 2016: 				}
 2017: 				if(($accessor{type} eq 'getset') || ($accessor{type} eq 'getter')) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2017_5: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2018: 					# Since Perl doesn't support data encapsulation, we can test the getter returns the correct item
 2019: 					$position_code .= 'if(scalar(@alist) == 1) { ';
 2020: 					$position_code .= "cmp_ok(\$result, 'eq', \$obj->{$accessor{property}}, 'getset function returns correct item');";
 2021: 					if($accessor{type} eq 'getter') {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2021_6: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2022: 						$position_code .= "if(defined(\$prev_value)) { cmp_ok(\$result, 'eq', \$prev_value, 'getter does not change value'); } ";
 2023: 					}
 2024: 					$position_code .= '}';
 2025: 				}
 2026: 				if($output{'_returns_self'}) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2026_5: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2027: 					croak("$accessor{type} for $accessor{property} cannot return \$self");
 2028: 				}
 2029: 			}
 2030: 		} else {
 2031: 			$call_code = "\$result = \$obj->$function(\$input);";
 2032: 			if($output{'_returns_self'}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2033: 				$call_code .= "ok(defined(\$result)); ok(\$result eq \$obj, '$function returns self')";
 2034: 			} elsif(defined($accessor{type}) && ($accessor{type} eq 'getset')) {
 2035: 				$call_code .= "ok(\$obj->$function() eq \$result, 'test getset accessor');"
 2036: 			}
 2037: 			if(scalar(keys %input) == 0) {
  Mutants (Total: 2, Killed: 2, Survived: 0)
 2038: 				if(defined($accessor{type}) && ($accessor{type} eq 'getter')) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2039: 					$call_code .= "cmp_ok(\$result, 'eq', \$obj->{$accessor{property}}, 'getter function returns correct item') if(defined(\$result));";
 2040: 				}
 2041: 			}
 2042: 		}
 2043: 	} elsif(defined($module) && length($module)) {
 2044: 		if($function eq 'new') {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2044_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2045: 			if($has_positions) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2045_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2046: 				$position_code = "\$result = (scalar(\@alist) == 1) ? ${module}\->$function(\$alist[0]) : (scalar(\@alist) == 0) ? ${module}\->$function() : ${module}\->$function(\@alist);";
 2047: 			} else {
 2048: 				$call_code = "\$result = ${module}\->$function(\$input);";
 2049: 			}
 2050: 		} else {
 2051: 			if($has_positions) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2051_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2052: 				$position_code = "\$result = (scalar(\@alist) == 1) ? ${module}::$function(\$alist[0]) : (scalar(\@alist) == 0) ? ${module}::$function() : ${module}::$function(\@alist);";
 2053: 			} else {
 2054: 				$call_code = "\$result = ${module}::$function(\$input);";
 2055: 			}
 2056: 		}
 2057: 	} else {
 2058: 		if($has_positions) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2058_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2059: 			$position_code = "\$result = $function(\@alist);";
 2060: 		} else {
 2061: 			$call_code = "\$result = $function(\$input);";
 2062: 		}
 2063: 	}
 2064: 
 2065: 	# List-context capture: $result = func() in scalar context returns a count, not the list.
 2066: 	# When the schema says output type is 'array', capture into @_r then take a ref.
●2067 → 2067 → 2077 2067: 	if(($output{type} // '') eq 'array') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2068: 		if(defined($call_code)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2069: 			$call_code =~ s/\A\$result = ([^;]+);/my \@_r = ($1); \$result = \\\@_r;/;
 2070: 		}
 2071: 		if(defined($position_code)) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2071_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2072: 			$position_code =~ s/\A\$result = ([^;]+);/my \@_r = ($1); \$result = \\\@_r;/;
 2073: 		}
 2074: 	}
 2075: 
 2076: 	# Build static corpus code
●2077 → 2078 → 2177 2077: 	my $corpus_code = '';
 2078: 	if (%all_cases) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2079: 		$corpus_code = "\n# --- Static Corpus Tests ---\n" .
 2080: 			"diag('Running " . scalar(keys %all_cases) . " corpus tests');\n";
 2081: 
 2082: 		for my $expected (sort keys %all_cases) {
 2083: 			my $inputs = $all_cases{$expected};
 2084: 			next unless($inputs);
 2085: 
 2086: 			my $expected_str = perl_quote($expected);
 2087: 			my $status = ((ref($inputs) eq 'HASH') && $inputs->{'_STATUS'}) // 'OK';
 2088: 			if($expected_str eq "'_STATUS:DIES'") {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2088_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2089: 				$status = 'DIES';
 2090: 			} elsif($expected_str eq "'_STATUS:WARNS'") {
 2091: 				$status = 'WARNS';
 2092: 			}
 2093: 
 2094: 			if(ref($inputs) eq 'HASH') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2095: 				$inputs = $inputs->{'input'};
 2096: 			}
 2097: 			my $input_str;
 2098: 			if(ref($inputs) eq 'ARRAY') {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2098_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2099: 				$input_str = join(', ', map { perl_quote($_) } @{$inputs});
 2100: 			} elsif(ref($inputs) eq 'HASH') {
 2101: 				$input_str = render_fallback($inputs);
 2102: 
 2103: 				# YAML can't express Perl's undef, so a corpus value of
 2104: 				# the sentinel string 'undef' means "this param is
 2105: 				# undef" -- convert the quoted sentinel back to the
 2106: 				# bareword so the generated test passes real undef
 2107: 				$input_str =~ s/=> 'undef'/=> undef/gms;
 2108: 			} else {
 2109: 				$input_str = $inputs;
 2110: 			}
 2111: 			if(($input_str eq 'undef') && (!$config{'test_undef'})) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2111_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2112: 				carp('corpus case set to undef, yet test_undef is not set in config');
 2113: 			}
 2114: 			if($new) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2114_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2115: 				if($status eq 'DIES') {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2115_5: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2116: 					$corpus_code .= "dies_ok { \$obj->$function($input_str) } " .
 2117: 							"'$function(" . join(', ', map { $_ // '' } @$inputs ) . ") dies';\n";
 2118: 				} elsif($status eq 'WARNS') {
 2119: 					$corpus_code .= "warnings_exist { \$obj->$function($input_str) } qr/./, " .
 2120: 							"'$function(" . join(', ', map { $_ // '' } @$inputs ) . ") warns';\n";
 2121: 				} else {
 2122: 					my $desc = sprintf("$function(%s) returns %s",
 2123: 						perl_quote(join(', ', map { $_ // '' } @$inputs )),
 2124: 						$expected_str
 2125: 					);
 2126: 					if(($output{'type'} // '') eq 'boolean') {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2126_6: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2127: 						if($expected_str eq '1') {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2127_7: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2128: 							$corpus_code .= "ok(\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
 2129: 						} elsif($expected_str eq '0') {
 2130: 							$corpus_code .= "ok(!\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
 2131: 						} else {
 2132: 							croak("Boolean is expected to return $expected_str");
 2133: 						}
 2134: 					} else {
 2135: 						$corpus_code .= "is(\$obj->$function($input_str), $expected_str, " . q_wrap($desc) . ");\n";
 2136: 					}
 2137: 				}
 2138: 			} else {
 2139: 				if($status eq 'DIES') {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2139_5: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2140: 					if($module) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2140_6: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2141: 						$corpus_code .= "dies_ok { $module\::$function($input_str) } " .
 2142: 							"'Corpus $expected dies';\n";
 2143: 					} else {
 2144: 						$corpus_code .= "dies_ok { $function($input_str) } " .
 2145: 							"'Corpus $expected dies';\n";
 2146: 					}
 2147: 				} elsif($status eq 'WARNS') {
 2148: 					if($module) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2148_6: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2149: 						$corpus_code .= "warnings_exist { $module\::$function($input_str) } qr/./, " .
 2150: 							"'Corpus $expected warns';\n";
 2151: 					} else {
 2152: 						$corpus_code .= "warnings_exist { $function($input_str) } qr/./, " .
 2153: 							"'Corpus $expected warns';\n";
 2154: 					}
 2155: 				} else {
 2156: 					my $desc = sprintf("$function(%s) returns %s",
 2157: 						perl_quote((ref $inputs eq 'ARRAY') ? (join(', ', map { $_ // '' } @{$inputs})) : $inputs),
 2158: 						$expected_str
 2159: 					);
 2160: 					if(($output{'type'} // '') eq 'boolean') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2161: 						if($expected_str eq '1') {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2161_7: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2162: 							$corpus_code .= "ok(\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
 2163: 						} elsif($expected_str eq '0') {
 2164: 							$corpus_code .= "ok(!\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
 2165: 						} else {
 2166: 							croak("Boolean is expected to return $expected_str");
 2167: 						}
 2168: 					} else {
 2169: 						$corpus_code .= "is(\$obj->$function($input_str), $expected_str, " . q_wrap($desc) . ");\n";
 2170: 					}
 2171: 				}
 2172: 			}
 2173: 		}
 2174: 	}
 2175: 
 2176: 	# Prepare seed/iterations code fragment for the generated test
●2177 → 2178 → 2184 2177: 	my $seed_code = '';
 2178: 	if (defined $seed) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2179: 		# ensure integer-ish
 2180: 		$seed = int($seed);
 2181: 		$seed_code = "srand($seed);\n";
 2182: 	}
 2183: 
●2184 → 2222 → 0 2184: 	my $determinism_code = 'my $result2;' .
 2185: 		'eval { $result2 = do { ' . (defined($position_code) ? $position_code : $call_code) . " }; };\n" .
 2186: 		'is_deeply($result2, $result, "deterministic result for same input");' .
 2187: 		"\n";
 2188: 
 2189: 	# Generate the test content
 2190: 	my $tt = Template->new({ ENCODING => 'utf8', TRIM => 1 });
 2191: 
 2192: 	# Read template from DATA handle
 2193: 	my $template_package = __PACKAGE__ . '::Template';
 2194: 	my $template = $template_package->get_data_section('test.tt');
 2195: 
 2196: 	my $vars = {
 2197: 		setup_code => $setup_code,
 2198: 		edge_cases_code => $edge_cases_code,
 2199: 		edge_case_array_code => $edge_case_array_code,
 2200: 		type_edge_cases_code => $type_edge_cases_code,
 2201: 		config_code => $config_code,
 2202: 		seed_code => $seed_code,
 2203: 		input_code => $input_code,
 2204: 		output_code => $output_code,
 2205: 		transforms_code => $transforms_code,
 2206: 		corpus_code => $corpus_code,
 2207: 		call_code => $call_code,
 2208: 		position_code => $position_code,
 2209: 		determinism_code => $determinism_code,
 2210: 		function => $function,
 2211: 		iterations_code => int($iterations),
 2212: 		use_properties => $use_properties,
 2213: 		transform_properties_code => $transform_properties_code,
 2214: 		property_trials => $config{properties}{trials} // $DEFAULT_PROPERTY_TRIALS,
 2215: 		relationships_code => $relationships_code,
 2216: 		module => $module
 2217: 	};
 2218: 
 2219: 	my $test;
 2220: 	$tt->process($template, $vars, \$test) or croak($tt->error());
 2221: 
 2222: 	if ($test_file) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2223: 		# autodie is disabled for this open -- under "use autodie qw(:all)"
 2224: 		# open() never returns false on failure, it throws its own exception
 2225: 		# instead, which would silently make the "or croak" dead code.
 2226: 		no autodie qw(open);
 2227: 		open my $fh, '>:encoding(UTF-8)', $test_file or croak "Cannot open $test_file: $!";
 2228: 		print $fh "$test\n";
 2229: 		close $fh;
 2230: 		if($module) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2231: 			print "Generated $test_file for $module\::$function with fuzzing + corpus support\n";
 2232: 		} else {
 2233: 			print "Generated $test_file for $function with fuzzing + corpus support\n";
 2234: 		}
 2235: 	} else {
 2236: 		print "$test\n";
 2237: 	}
 2238: }
 2239: 
 2240: # --- Helpers for rendering data structures into Perl code for the generated test ---
 2241: 
 2242: # --------------------------------------------------
 2243: # _is_perl_builtin
 2244: #
 2245: # Purpose:    Return true if a string is the name of
 2246: #             a Perl core builtin function, to prevent
 2247: #             it being used as a module name in
 2248: #             use_ok() calls in generated tests.
 2249: #
 2250: # Entry:      $name - the string to check.
 2251: # Exit:       Returns 1 if builtin, 0 otherwise.
 2252: # --------------------------------------------------
 2253: sub _is_perl_builtin {
 2254: 	my $name = $_[0];
 2255: 	return 0 unless defined $name;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 2256: 
 2257: 	state %BUILTINS = map { $_ => 1 } qw(
 2258: 		abs accept alarm atan2 bind binmode bless
 2259: 		caller chdir chmod chomp chop chown chr chroot
 2260: 		close closedir connect cos crypt
 2261: 		dbmclose dbmopen defined delete die do dump
 2262: 		each endgrent endhostent endnetent endprotoent endpwent endservent
 2263: 		eof eval exec exists exit exp
 2264: 		fcntl fileno flock fork format formline
 2265: 		getc getgrent getgrgid getgrnam gethostbyaddr gethostbyname
 2266: 		gethostent getlogin getnetbyaddr getnetbyname getnetent
 2267: 		getpeername getpgrp getppid getpriority getprotobyname
 2268: 		getprotobynumber getprotoent getpwent getpwnam getpwuid
 2269: 		getservbyname getservbyport getservent getsockname getsockopt
 2270: 		glob gmtime goto grep
 2271: 		hex
 2272: 		index int ioctl
 2273: 		join
 2274: 		keys kill
 2275: 		last lc lcfirst length link listen local localtime log lstat
 2276: 		map mkdir msgctl msgget msgrcv msgsnd my
 2277: 		next no
 2278: 		oct open opendir ord our
 2279: 		pack pipe pop pos print printf prototype push
 2280: 		quotemeta
 2281: 		rand read readdir readline readlink readpipe recv redo
 2282: 		ref rename require reset return reverse rewinddir rindex rmdir
 2283: 		say scalar seek seekdir select semctl semget semop send
 2284: 		setgrent sethostent setnetent setpgrp setpriority setprotoent
 2285: 		setpwent setservent setsockopt shift shmctl shmget shmread
 2286: 		shmwrite shutdown sin sleep socket socketpair sort splice split
 2287: 		sprintf sqrt srand stat study sub substr symlink syscall
 2288: 		sysopen sysread sysseek system syswrite
 2289: 		tell telldir tie tied time times truncate
 2290: 		uc ucfirst umask undef unlink unpack unshift untie use
 2291: 		utime values vec wait waitpid wantarray warn write
 2292: 	);
 2293: 	return $BUILTINS{lc $name} // 0;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 2294: }
 2295: 
 2296: # --------------------------------------------------
 2297: # _load_schema
 2298: #
 2299: # Load and parse a schema file using
 2300: #     Config::Abstraction, returning the
 2301: #     schema as a hashref.
 2302: #
 2303: # Entry:      $schema_file - path to the schema file.
 2304: #             Must be defined, non-empty, and readable.
 2305: #
 2306: # Exit:       Returns a hashref of the parsed schema
 2307: #             with a '_source' key added containing
 2308: #             the originating file path.
 2309: #             Croaks on any error.
 2310: #
 2311: # Side effects: Reads from the filesystem.
 2312: #
 2313: # Notes:      Legacy Perl-file configs (containing
 2314: #             '$module' or 'our $module' keys) are
 2315: #             rejected with a clear error. Config::
 2316: #             Abstraction is used rather than require()
 2317: #             to avoid executing arbitrary code from
 2318: #             user-supplied config files.
 2319: # --------------------------------------------------
 2320: sub _load_schema {
●2321 → 2335 → 2354 2321: 	my $schema_file = $_[0];
 2322: 
 2323: 	# Validate the argument before touching the filesystem
 2324: 	croak(__PACKAGE__, ': Usage: _load_schema($schema_file)') unless defined $schema_file;
 2325: 
 2326: 	croak(__PACKAGE__, ': _load_schema given empty filename') unless length($schema_file);
 2327: 
 2328: 	# Confirm the file exists and is readable before attempting
 2329: 	# to load it — gives a clearer error than Config::Abstraction would
 2330: 	croak(__PACKAGE__, ": _load_schema($schema_file): $!") unless -r $schema_file;
 2331: 
 2332: 	# Load configuration via Config::Abstraction which supports
 2333: 	# YAML, JSON, and other formats without executing arbitrary code.
 2334: 	# no_fixate prevents automatic type coercion that could alter values
 2335: 	if(my $schema = Config::Abstraction->new(
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2336: 		config_dirs  => ['.', ''],
 2337: 		config_file  => $schema_file,
 2338: 		no_fixate    => 1,
 2339: 	)) {
 2340: 		if($schema = $schema->all()) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2341: 			# Detect legacy Perl config files by the presence of
 2342: 			# variable declaration keys — these are no longer supported
 2343: 			if(exists($schema->{$LEGACY_PERL_KEY_1}) ||
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2344: 			   exists($schema->{$LEGACY_PERL_KEY_2})) {
 2345: 				croak("$schema_file: Loading perl files as configs is no longer supported");
 2346: 			}
 2347: 
 2348: 			# Tag the schema with its source path for error messages
 2349: 			$schema->{$SOURCE_KEY} = $schema_file;
 2350: 			return $schema;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 2351: 		}
 2352: 	}
 2353: 
 2354: 	croak "Failed to load schema from $schema_file";
 2355: }
 2356: 
 2357: # --------------------------------------------------
 2358: # _load_schema_section
 2359: #
 2360: # Purpose:    Extract a named section from a parsed
 2361: #             schema hashref, validating that it is
 2362: #             a hashref if present.
 2363: #
 2364: # Entry:      $schema      - the full parsed schema hashref.
 2365: #             $section     - name of the section to extract
 2366: #                            (e.g. 'input', 'output').
 2367: #             $schema_file - path of the schema file,
 2368: #                            used in error messages only.
 2369: #
 2370: # Exit:       Returns the section hashref if present,
 2371: #             or an empty hashref {} if absent.
 2372: #             Croaks if the section exists but is not
 2373: #             a hashref (and not the string 'undef').
 2374: #
 2375: # Notes:      The string 'undef' is treated as an
 2376: #             absent section — callers that set a
 2377: #             section to 'undef' in YAML get the same
 2378: #             result as omitting it entirely.
 2379: # --------------------------------------------------
 2380: sub _load_schema_section {
 2381: 	my ($schema, $section, $schema_file) = @_;
 2382: 
 2383: 	# Section absent — return empty hash as the safe default
 2384: 	return {} unless exists $schema->{$section};
 2385: 
 2386: 	# Section present and is a hashref — return it directly
 2387: 	return $schema->{$section}
  Mutants (Total: 2, Killed: 2, Survived: 0)
 2388: 		if ref($schema->{$section}) eq 'HASH';
 2389: 
 2390: 	# Treat the YAML scalar 'undef' as equivalent to absent
 2391: 	return {}
 2392: 		if defined($schema->{$section}) &&
 2393: 		   $schema->{$section} eq 'undef';
 2394: 
 2395: 	# Section present but wrong type — croak with a clear message
 2396: 	# showing what type was found so the user can fix their schema
 2397: 	croak(
 2398: 		"$schema_file: $section should be a hash, not ",
 2399: 		ref($schema->{$section}) || $schema->{$section}
 2400: 	);
 2401: }
 2402: 
 2403: # --------------------------------------------------
 2404: # _validate_config
 2405: #
 2406: # Purpose:    Validate the top-level schema hashref
 2407: #             loaded from a schema file, checking that
 2408: #             required fields are present and that all
 2409: #             input parameters, types, positions, and
 2410: #             transform properties are well-formed.
 2411: #
 2412: # Entry:      $schema - the full parsed schema hashref
 2413: #             as returned by _load_schema().
 2414: #
 2415: # Exit:       Returns nothing on success.
 2416: #             Croaks on any structural error.
 2417: #             Carps on non-fatal warnings (unknown
 2418: #             semantic types, position gaps, missing
 2419: #             input/output definitions).
 2420: #
 2421: # Side effects: May delete $schema->{input} if its
 2422: #               value is the string 'undef'.
 2423: #
 2424: # Notes:      The parameter is named $schema throughout
 2425: #             to distinguish the top-level schema from
 2426: #             the nested config sub-hash. _validate_config
 2427: #             is called before _normalize_config so config
 2428: #             boolean normalisation has not yet occurred.
 2429: # --------------------------------------------------
 2430: sub _validate_config {
●2431 → 2435 → 2441 2431: 	my $schema = $_[0];
 2432: 
 2433: 	# At least one of module or function must be present —
 2434: 	# without these we cannot generate any meaningful test
 2435: 	if(!defined($schema->{'module'}) && !defined($schema->{'function'})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2436: 		croak('At least one of function and module must be defined');
 2437: 	}
 2438: 
 2439: 	# Warn if neither input nor output is defined — a few
 2440: 	# generic tests can still be generated but it is unusual
●2441 → 2441 → 2446 2441: 	if(!defined($schema->{'input'}) && !defined($schema->{'output'})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2442: 		carp('Neither input nor output is defined, only a few tests will be generated');
 2443: 	}
 2444: 
 2445: 	# Normalise input: the string 'undef' means no input defined
●2446 → 2446 → 2455 2446: 	if($schema->{'input'} && ref($schema->{input}) ne 'HASH') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2447: 		if($schema->{'input'} eq 'undef') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2448: 			delete $schema->{'input'};
 2449: 		} else {
 2450: 			croak("Invalid input specification: expected hash, got '$schema->{'input'}'");
 2451: 		}
 2452: 	}
 2453: 
 2454: 	# Validate each input parameter if input is defined
●2455 → 2455 → 2462 2455: 	if($schema->{input}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2456: 		_validate_input_params($schema);
 2457: 		_validate_input_positions($schema);
 2458: 		_validate_input_semantics($schema);
 2459: 	}
 2460: 
 2461: 	# Validate transform property definitions if present
●2462 → 2462 → 2467 2462: 	if(exists($schema->{transforms}) && ref($schema->{transforms}) eq 'HASH') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2463: 		_validate_transform_properties($schema);
 2464: 	}
 2465: 
 2466: 	# Validate any nested config sub-hash keys against known types
●2467 → 2467 → 0 2467: 	if(ref($schema->{config}) eq 'HASH') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2468: 		for my $k (keys %{$schema->{'config'}}) {
 2469: 			# %VALID_CONFIG_KEYS is the authoritative set — O(1) hash lookup
 2470: 			croak "unknown config setting '$k'"
 2471: 				unless $VALID_CONFIG_KEYS{$k};
 2472: 		}
 2473: 	}
 2474: }
 2475: 
 2476: # --------------------------------------------------
 2477: # _validate_input_params
 2478: #
 2479: # Purpose:    Validate type specifications for each
 2480: #             named input parameter.
 2481: #
 2482: # Entry:      $schema - the full parsed schema hashref.
 2483: #             $schema->{input} must be a hashref.
 2484: #
 2485: # Exit:       Returns nothing. Croaks on invalid type.
 2486: # --------------------------------------------------
 2487: sub _validate_input_params {
●2488 → 2490 → 0 2488: 	my $schema = $_[0];
 2489: 
 2490: 	for my $param (keys %{$schema->{input}}) {
 2491: 		# Catch empty parameter names — these would produce
 2492: 		# broken Perl variable names in the generated test
 2493: 		croak 'Empty input parameter name'
 2494: 			unless length($param);
 2495: 
 2496: 		my $spec = $schema->{input}{$param};
 2497: 
 2498: 		# Validate the type field — required for all parameters
 2499: 		if(ref($spec)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2500: 			croak("Missing type for parameter '$param'")
 2501: 				unless defined $spec->{type};
 2502: 			# 'coderef' is a SchemaExtractor-specific type; treat as 'any'
 2503: 			$spec->{type} = 'any' if $spec->{type} eq 'coderef';
 2504: 			croak("Invalid type '$spec->{type}' for parameter '$param'")
 2505: 				unless _valid_type($spec->{type});
 2506: 		} else {
 2507: 			croak("Invalid type '$spec' for parameter '$param'")
 2508: 				unless _valid_type($spec);
 2509: 		}
 2510: 	}
 2511: }
 2512: 
 2513: # --------------------------------------------------
 2514: # _validate_input_positions
 2515: #
 2516: # Purpose:    Validate positional argument declarations
 2517: #             in the input schema — positions must be
 2518: #             non-negative integers with no duplicates,
 2519: #             and either all or no parameters must have
 2520: #             positions.
 2521: #
 2522: # Entry:      $schema - the full parsed schema hashref.
 2523: #             $schema->{input} must be a hashref.
 2524: #
 2525: # Exit:       Returns nothing. Croaks on invalid or
 2526: #             duplicate positions. Carps on gaps.
 2527: # --------------------------------------------------
 2528: sub _validate_input_positions {
●2529 → 2534 → 2555 2529: 	my $schema = $_[0];
 2530: 
 2531: 	my $has_positions = 0;
 2532: 	my %positions;
 2533: 
 2534: 	for my $param (keys %{$schema->{input}}) {
 2535: 		my $spec = $schema->{input}{$param};
 2536: 
 2537: 		# Only process params that explicitly declare a position
 2538: 		next unless ref($spec) eq 'HASH' && defined($spec->{position});
 2539: 
 2540: 		$has_positions = 1;
 2541: 		my $pos = $spec->{position};
 2542: 
 2543: 		# Position must be a non-negative integer
 2544: 		croak "Position for '$param' must be a non-negative integer"
 2545: 			unless $pos =~ /^\d+$/;
 2546: 
 2547: 		# Duplicate positions would produce ambiguous generated tests
 2548: 		croak "Duplicate position $pos for parameters '$positions{$pos}' and '$param'"
 2549: 			if exists $positions{$pos};
 2550: 
 2551: 		$positions{$pos} = $param;
 2552: 	}
 2553: 
 2554: 	# If any param has a position, all params must have one
●2555 → 2555 → 0 2555: 	if($has_positions) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2556: 		for my $param (keys %{$schema->{input}}) {
 2557: 			my $spec = $schema->{input}{$param};
 2558: 			unless(ref($spec) eq 'HASH' && defined($spec->{position})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2559: 				croak "Parameter '$param' missing position " .
 2560: 					'(all params must have positions if any do)';
 2561: 			}
 2562: 		}
 2563: 
 2564: 		# Check for gaps — positions must be a contiguous sequence
 2565: 		# starting at 0, otherwise the generated test will be wrong
 2566: 		my @sorted = sort { $a <=> $b } keys %positions;
 2567: 		for my $i (0 .. $#sorted) {
 2568: 			if($sorted[$i] != $i) {
  Mutants (Total: 2, Killed: 2, Survived: 0)
 2569: 				carp "Position sequence has gaps (positions: @sorted)";
 2570: 				last;
 2571: 			}
 2572: 		}
 2573: 	}
 2574: }
 2575: 
 2576: # --------------------------------------------------
 2577: # _validate_input_semantics
 2578: #
 2579: # Purpose:    Validate semantic type annotations and
 2580: #             enum/memberof constraints on input params.
 2581: #
 2582: # Entry:      $schema - the full parsed schema hashref.
 2583: #             $schema->{input} must be a hashref.
 2584: #
 2585: # Exit:       Returns nothing. Croaks on conflicting
 2586: #             or malformed enum/memberof. Carps on
 2587: #             unknown semantic types.
 2588: # --------------------------------------------------
 2589: sub _validate_input_semantics {
●2590 → 2594 → 0 2590: 	my $schema = $_[0];
 2591: 
 2592: 	my $semantic_generators = _get_semantic_generators();
 2593: 
 2594: 	for my $param (keys %{$schema->{input}}) {
 2595: 		my $spec = $schema->{input}{$param};
 2596: 		next unless ref($spec) eq 'HASH';
 2597: 
 2598: 		# Warn on unknown semantic types rather than croaking —
 2599: 		# new semantic types may be added without updating this list
 2600: 		if(defined($spec->{semantic})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2601: 			my $semantic = $spec->{semantic};
 2602: 			unless(exists $semantic_generators->{$semantic}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2603: 				carp "Unknown semantic type '$semantic' for parameter '$param'. " .
 2604: 					'Available types: ' .
 2605: 					join(', ', sort keys %{$semantic_generators});
 2606: 			}
 2607: 		}
 2608: 
 2609: 		# enum and memberof are mutually exclusive representations
 2610: 		# of the same concept — having both is always a schema error
 2611: 		if($spec->{'enum'} && $spec->{'memberof'}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2612: 			croak "$param: has both enum and memberof";
 2613: 		}
 2614: 
 2615: 		# Both enum and memberof must be arrayrefs when present
 2616: 		for my $type ('enum', 'memberof') {
 2617: 			if(exists $spec->{$type}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2618: 				croak "$type must be an arrayref"
 2619: 					unless ref($spec->{$type}) eq 'ARRAY';
 2620: 			}
 2621: 		}
 2622: 	}
 2623: }
 2624: 
 2625: # --------------------------------------------------
 2626: # _validate_transform_properties
 2627: #
 2628: # Purpose:    Validate the properties array in each
 2629: #             transform definition, checking that each
 2630: #             property is either a known builtin name
 2631: #             or a custom hashref with name and code.
 2632: #
 2633: # Entry:      $schema - the full parsed schema hashref.
 2634: #             $schema->{transforms} must be a hashref.
 2635: #
 2636: # Exit:       Returns nothing. Croaks on invalid property
 2637: #             definitions. Carps on unknown builtins.
 2638: # --------------------------------------------------
 2639: sub _validate_transform_properties {
●2640 → 2644 → 0 2640: 	my $schema = $_[0];
 2641: 
 2642: 	my $builtin_props = _get_builtin_properties();
 2643: 
 2644: 	for my $transform_name (keys %{$schema->{transforms}}) {
 2645: 		my $transform = $schema->{transforms}{$transform_name};
 2646: 
 2647: 		# properties is optional — skip transforms that don't define it
 2648: 		next unless exists $transform->{properties};
 2649: 
 2650: 		croak "Transform '$transform_name': properties must be an array"
 2651: 			unless ref($transform->{properties}) eq 'ARRAY';
 2652: 
 2653: 		for my $prop (@{$transform->{properties}}) {
 2654: 			if(!ref($prop)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2655: 				# Plain string — must be a known builtin property name
 2656: 				unless(exists $builtin_props->{$prop}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2657: 					carp "Transform '$transform_name': unknown built-in property '$prop'. " .
 2658: 						'Available: ' .
 2659: 						join(', ', sort keys %{$builtin_props});
 2660: 				}
 2661: 			} elsif(ref($prop) eq 'HASH') {
 2662: 				# Custom property — must have both name and code fields
 2663: 				unless($prop->{name} && $prop->{code}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2664: 					croak "Transform '$transform_name': " .
 2665: 						"custom properties must have 'name' and 'code' fields";
 2666: 				}
 2667: 			} else {
 2668: 				croak "Transform '$transform_name': invalid property definition";
 2669: 			}
 2670: 		}
 2671: 	}
 2672: }
 2673: 
 2674: # --------------------------------------------------
 2675: # _normalize_config
 2676: #
 2677: # Purpose:    Normalise boolean string values in the
 2678: #             config sub-hash to Perl integers (1/0),
 2679: #             and default absent boolean fields to 1
 2680: #             (enabled). The 'properties' field is a
 2681: #             hashref not a boolean and is handled
 2682: #             separately.
 2683: #
 2684: # Entry:      $config - the config sub-hash extracted
 2685: #             from the schema (i.e. $schema->{config}).
 2686: #             May be empty.
 2687: #
 2688: # Exit:       Returns nothing. Modifies $config in place.
 2689: #
 2690: # Side effects: Modifies the caller's config hashref.
 2691: #
 2692: # Notes:      String-to-boolean conversion is delegated
 2693: #             to %Readonly::Values::Boolean::booleans
 2694: #             which handles 'yes'/'no', 'on'/'off',
 2695: #             'true'/'false' etc. Fields not present in
 2696: #             the config hash are defaulted to 1 so
 2697: #             that test generation is maximally thorough
 2698: #             unless the schema explicitly disables a
 2699: #             feature.
 2700: # --------------------------------------------------
 2701: sub _normalize_config {
●2702 → 2704 → 2725 2702: 	my $config = $_[0];
 2703: 
 2704: 	for my $field (keys %VALID_CONFIG_KEYS) {
 2705: 		# Non-boolean fields are handled separately
 2706: 		next if $field eq $CONFIG_PROPERTIES_KEY;
 2707: 		next if $field eq 'timeout';	# numeric, not boolean; absence means use generated-test default
 2708: 
 2709: 		if(exists($config->{$field}) && defined($config->{$field})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2710: 			# Convert string boolean representations to integers
 2711: 			# using the lookup table from Readonly::Values::Boolean
 2712: 			if(defined(my $b = $Readonly::Values::Boolean::booleans{$config->{$field}})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2713: 				$config->{$field} = $b;
 2714: 			}
 2715: 		} else {
 2716: 			# Default absent boolean fields to enabled (1) so that
 2717: 			# test generation is comprehensive unless explicitly disabled
 2718: 			$config->{$field} = 1;
 2719: 		}
 2720: 	}
 2721: 
 2722: 	# Ensure properties is always a hashref — if absent or set to
 2723: 	# a non-hash value, replace with a disabled default so that
 2724: 	# downstream code can safely dereference it without checking ref()
 2725: 	$config->{$CONFIG_PROPERTIES_KEY} = { enable => 0 } unless ref($config->{$CONFIG_PROPERTIES_KEY}) eq 'HASH';
 2726: }
 2727: 
 2728: # --------------------------------------------------
 2729: # _valid_type
 2730: #
 2731: # Determine whether a string is a
 2732: #     recognised schema field type accepted
 2733: #     by the generator.
 2734: #
 2735: # Entry:      $type - the type string to validate.
 2736: #             May be undef.
 2737: #
 2738: # Exit:       Returns 1 if the type is known,
 2739: #             0 if the type is unknown or undef.
 2740: #
 2741: # Notes:      The lookup hash is declared with
 2742: #             'state' so it is built only once per
 2743: #             process rather than on every call —
 2744: #             important since _valid_type is called
 2745: #             in a loop over all input parameters.
 2746: #
 2747: #             'int' and 'bool' are accepted as
 2748: #             aliases for 'integer' and 'boolean'
 2749: #             respectively, for compatibility with
 2750: #             schemas generated by external tools
 2751: #             that use the shorter forms.
 2752: # --------------------------------------------------
 2753: sub _valid_type {
 2754: 	my $type = $_[0];
 2755: 
 2756: 	# Undef is never a valid type
 2757: 	return 0 unless defined($type);
  Mutants (Total: 2, Killed: 2, Survived: 0)
 2758: 
 2759: 	# Build the lookup table once and cache it for
 2760: 	# the lifetime of the process via 'state'
 2761: 	state %VALID = map { $_ => 1 } qw(
 2762: 		string boolean integer number float
 2763: 		hashref arrayref object int bool any
 2764: 	);
 2765: 
 2766: 	return($VALID{$type} // 0);
 2767: }
 2768: 
 2769: # --------------------------------------------------
 2770: # _assert_identifier
 2771: #
 2772: # Purpose:    Validate that a string is shaped like a
 2773: #             plain Perl identifier (or, with
 2774: #             package => 1, a "::"-separated package
 2775: #             name) before it is spliced into generated
 2776: #             test source as a bareword, package name,
 2777: #             method name, or variable name rather than
 2778: #             a quoted string literal. Schema-derived
 2779: #             names (module, function, transform names)
 2780: #             are spliced unescaped at the call sites
 2781: #             that use this guard, so an unvalidated
 2782: #             name could otherwise break out of the
 2783: #             generated source and inject arbitrary
 2784: #             Perl into a file that L<prove> will run.
 2785: #
 2786: # Entry:      $name - the string to validate.
 2787: #             $what - short label for the value, used
 2788: #                     only in the croak message.
 2789: #             %opts - package => 1 allows "::"
 2790: #                     separators in $name.
 2791: #
 2792: # Exit:       Returns $name unchanged on success.
 2793: #             Croaks if $name is not identifier-shaped.
 2794: # --------------------------------------------------
 2795: sub _assert_identifier {
 2796: 	my ($name, $what, %opts) = @_;
 2797: 
 2798: 	croak(__PACKAGE__, ": $what is missing or empty")
 2799: 		unless defined($name) && length($name);
 2800: 
 2801: 	my $re = $opts{package}
 2802: 		? qr/^[A-Za-z_]\w*(?:::[A-Za-z_]\w*)*\z/
 2803: 		: qr/^[A-Za-z_]\w*\z/;
 2804: 
 2805: 	croak(__PACKAGE__, ": $what '$name' is not a valid Perl identifier")
 2806: 		unless $name =~ $re;
 2807: 
 2808: 	return $name;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 2809: }
 2810: 
 2811: # --------------------------------------------------
 2812: # _validate_module
 2813: #
 2814: # Purpose:    Check whether the module named in a
 2815: #             schema can be found in @INC during
 2816: #             test generation. Optionally also
 2817: #             attempts to load it if the
 2818: #             GENERATOR_VALIDATE_LOAD environment
 2819: #             variable is set.
 2820: #
 2821: # Entry:      $module      - the module name to
 2822: #                            check. If undef or
 2823: #                            empty, returns 1
 2824: #                            immediately (builtin
 2825: #                            functions need no
 2826: #                            module).
 2827: #             $schema_file - path to the schema
 2828: #                            file, used in warning
 2829: #                            messages only.
 2830: #
 2831: # Exit:       Returns 1 if the module was found
 2832: #             (and loaded, if validation was
 2833: #             requested).
 2834: #             Returns 0 if the module was not
 2835: #             found or failed to load — this is
 2836: #             non-fatal; generation continues.
 2837: #             Returns 1 immediately for undef or
 2838: #             empty $module.
 2839: #
 2840: # Side effects: Prints to STDERR when TEST_VERBOSE
 2841: #               or GENERATOR_VERBOSE is set.
 2842: #               Carps (non-fatally) when the module
 2843: #               cannot be found or loaded.
 2844: #               May attempt to load the module into
 2845: #               the current process when
 2846: #               GENERATOR_VALIDATE_LOAD is set —
 2847: #               this can have side effects depending
 2848: #               on the module.
 2849: #
 2850: # Notes:      Not finding a module during generation
 2851: #             is intentionally non-fatal — the module
 2852: #             may be available on the target machine
 2853: #             even if not on the generation machine.
 2854: #             Verbose output goes to STDERR via
 2855: #             print rather than carp since it is
 2856: #             informational, not a warning.
 2857: # --------------------------------------------------
 2858: sub _validate_module {
●2859 → 2867 → 2880 2859: 	my ($module, $schema_file) = @_;
 2860: 
 2861: 	# Builtin functions have no module to validate
 2862: 	return 1 unless $module;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 2863: 
 2864: 	# Check whether the module is findable in @INC
 2865: 	my $mod_info = check_install(module => $module);
 2866: 
 2867: 	if($schema_file && !$mod_info) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2868: 		# Non-fatal — emit a single consolidated warning so
 2869: 		# the caller sees one message rather than four
 2870: 		carp(
 2871: 			"Module '$module' not found in \@INC during generation.\n" .
 2872: 			"  Config file: $schema_file\n" .
 2873: 			"  This is OK if the module will be available when tests run.\n" .
 2874: 			'  If unexpected, check your module name and installation.'
 2875: 		);
 2876: 		return 0;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 2877: 	}
 2878: 
 2879: 	# Check once and reuse — avoids evaluating two env vars twice
●2880 → 2882 → 2891 2880: 	my $verbose = $ENV{$ENV_TEST_VERBOSE} || $ENV{$ENV_GENERATOR_VERBOSE};
 2881: 
 2882: 	if($verbose) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2883: 		carp "Found module '$module' at: $mod_info->{'file'} " .
 2884: 			'(version ' . ($mod_info->{'version'} || 'unknown') . ')';
 2885: 	}
 2886: 
 2887: 	# Optional load validation — disabled by default because
 2888: 	# loading a module can have side effects (e.g. BEGIN blocks,
 2889: 	# database connections, file I/O) that are undesirable
 2890: 	# during generation
●2891 → 2891 → 2908 2891: 	if($ENV{$ENV_VALIDATE_LOAD}) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2891_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2892: 		my $loaded = can_load(modules => { $module => undef }, verbose => 0);
 2893: 
 2894: 		if(!$loaded) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2895: 			my $err = $Module::Load::Conditional::ERROR || 'unknown error';
 2896: 			carp(
 2897: 				"Module '$module' found but failed to load: $err\n" .
 2898: 				'  This might indicate a broken installation or missing dependencies.'
 2899: 			);
 2900: 			return 0;

					

					
Mutants (Total: 2, Killed: 0, Survived: 2)
					

				
BOOL_NEGATE_2900_4: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes

								

								
🧪 Suggested Test
								
# Boolean branch test suggestion
ok( !func(INPUT), 'Verify boolean branch behaviour' );

								
							
RETURN_UNDEF_2900_4: Replace return expression with undef
LOW: Mutation survived, but impact may be minor

								

								
🧪 Suggested Test
								
# Return value assertion
is( func(INPUT), EXPECTED, 'Verify correct return value' );

								
							
 2901: 		}
 2902: 
 2903: 		if($verbose) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_2903_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 2904: 			carp "Successfully loaded module '$module'";
 2905: 		}
 2906: 	}
 2907: 
 2908: 	return 1;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 2909: }
 2910: 
 2911: =head2 render_fallback
 2912: 
 2913: Render any Perl value into a compact Perl source-code string using
 2914: L<Data::Dumper>. Used as a catch-all when no more specific renderer
 2915: applies.
 2916: 
 2917:     my $code = render_fallback({ key => 'value' });
 2918:     # returns: "{'key' => 'value'}"
 2919: 
 2920: =head3 Arguments
 2921: 
 2922: =over 4
 2923: 
 2924: =item * C<$v>
 2925: 
 2926: Any Perl value, including undef, scalars, refs, and blessed objects.
 2927: 
 2928: =back
 2929: 
 2930: =head3 Returns
 2931: 
 2932: A string of Perl source code that reproduces the value when evaluated.
 2933: Returns the string C<'undef'> when C<$v> is undef.
 2934: 
 2935: =head3 Side effects
 2936: 
 2937: Temporarily sets C<$Data::Dumper::Terse> and C<$Data::Dumper::Indent>
 2938: to produce compact single-line output. Both are restored on return via
 2939: C<local>.
 2940: 
 2941: =head3 Notes
 2942: 
 2943: The output is always a single line with no trailing newline. Suitable
 2944: for embedding in generated test code where readability is secondary to
 2945: correctness.
 2946: 
 2947: =head3 API specification
 2948: 
 2949: =head4 input
 2950: 
 2951:     { v => { type => 'any', optional => 1 } }
 2952: 
 2953: =head4 output
 2954: 
 2955:     { type => 'string' }
 2956: 
 2957: =cut
 2958: 
 2959: sub render_fallback {
 2960: 	my $v = $_[0];
 2961: 
 2962: 	# Handle undef explicitly rather than letting Dumper produce
 2963: 	# 'undef' without the localised settings applied
 2964: 	return 'undef' unless defined $v;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 2965: 
 2966: 	# Use Terse+Indent=0 to produce compact single-line output
 2967: 	# suitable for embedding in generated test code
 2968: 	local $Data::Dumper::Terse  = 1;
 2969: 	local $Data::Dumper::Indent = 0;
 2970: 
 2971: 	my $s = Dumper($v);
 2972: 
 2973: 	# Remove trailing newline that Dumper always appends
 2974: 	chomp $s;
 2975: 	return $s;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 2976: }
 2977: 
 2978: =head2 render_hash
 2979: 
 2980: Render a two-level hashref (parameter name => spec hashref) into Perl
 2981: source code suitable for embedding in a generated test file as the
 2982: input specification passed to L<Params::Validate::Strict>.
 2983: 
 2984:     my $code = render_hash(\%input);
 2985: 
 2986: =head3 Arguments
 2987: 
 2988: =over 4
 2989: 
 2990: =item * C<$href>
 2991: 
 2992: A hashref whose values are themselves hashrefs containing field
 2993: specifications. A scalar value that is a recognised type string (see
 2994: C<_valid_type>) is expanded to C<{ type =E<gt> $value }>. Any other
 2995: non-hashref value is skipped with a warning.
 2996: 
 2997: =back
 2998: 
 2999: =head3 Returns
 3000: 
 3001: A string of comma-separated Perl source-code lines, one per key, of
 3002: the form:
 3003: 
 3004:     'key' => { subkey => value, ... }
 3005: 
 3006: Returns an empty string if C<$href> is undef, empty, or not a hashref.
 3007: 
 3008: =head3 Notes
 3009: 
 3010: The C<matches> and C<nomatch> sub-keys are treated specially — their
 3011: values are compiled to C<Regexp> objects via C<eval { qr/.../ }> and
 3012: then rendered using C<perl_quote> so they appear as C<qr{...}> in the
 3013: generated test. This prevents unmatched bracket characters in the
 3014: pattern from causing compilation failures.
 3015: 
 3016: Other sub-keys are rendered via C<perl_quote>.
 3017: 
 3018: =head3 API specification
 3019: 
 3020: =head4 input
 3021: 
 3022:     { href => { type => 'any', optional => 1 } }
 3023: 
 3024: =head4 output
 3025: 
 3026:     { type => 'string' }
 3027: 
 3028: =cut
 3029: 
 3030: sub render_hash {
●3031 → 3039 → 3097 3031: 	my $href = $_[0];
 3032: 
 3033: 	# Return empty string for absent or non-hash input — callers
 3034: 	# treat '' as "no input specification" in the generated test
 3035: 	return '' unless $href && ref($href) eq 'HASH';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3036: 
 3037: 	my @lines;
 3038: 
 3039: 	for my $k (sort keys %{$href}) {
 3040: 		my $def = $href->{$k};
 3041: 
 3042: 		# Handle scalar shorthand — 'arg1: string' is equivalent to
 3043: 		# 'arg1: { type: string }' and is explicitly supported by the
 3044: 		# validation layer in _validate_input_params
 3045: 		unless(defined($def) && ref($def) eq 'HASH') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 3046: 			if(defined($def) && !ref($def) && _valid_type($def)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 3047: 				# Expand scalar type shorthand to a full spec hashref
 3048: 				$def = { type => $def };
 3049: 			} else {
 3050: 				carp "render_hash: skipping key '$k' — value is not a hashref or recognised type string";
 3051: 				next;
 3052: 			}
 3053: 		}
 3054: 
 3055: 		my @pairs;
 3056: 
 3057: 		for my $subk (sort keys %{$def}) {
 3058: 			# Skip undef sub-values — they contribute nothing to the spec
 3059: 			next unless defined $def->{$subk};
 3060: 
 3061: 			# Validate that reference types are ones we can render —
 3062: 			# nested hashrefs are not yet supported
 3063: 			if(ref($def->{$subk})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 3064: 				unless((ref($def->{$subk}) eq 'ARRAY') ||

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_3064_5: Invert condition unless to if
MEDIUM: Add tests asserting both true and false outcomes

 3065: 				       (ref($def->{$subk}) eq 'Regexp')) {
 3066: 					croak(
 3067: 						__PACKAGE__,
 3068: 						": $subk is a nested element, not yet supported (",
 3069: 						ref($def->{$subk}), ')'
 3070: 					);
 3071: 				}
 3072: 			}
 3073: 
 3074: 			# matches and nomatch values must be Regexp objects in the
 3075: 			# generated test — compile raw strings safely via eval so
 3076: 			# patterns containing [ or \ don't cause compile failures
 3077: 			if(($subk eq $KEY_MATCHES) || ($subk eq $KEY_NOMATCH)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 3078: 				my $re = ref($def->{$subk}) eq 'Regexp'
 3079: 					? $def->{$subk}
 3080: 					: eval { qr/$def->{$subk}/ };
 3081: 				if($@ || !defined($re)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 3082: 					carp "render_hash: invalid $subk pattern '$def->{$subk}': $@";
 3083: 					next;
 3084: 				}
 3085: 				push @pairs, "$subk => " . perl_quote($re);
 3086: 			} else {
 3087: 				# All other sub-keys are rendered via perl_quote which
 3088: 				# handles scalars, arrayrefs, and Regexp objects correctly
 3089: 				push @pairs, "$subk => " . perl_quote($def->{$subk});
 3090: 			}
 3091: 		}
 3092: 
 3093: 		# Use "\t" rather than a literal tab for clarity and grep-ability
 3094: 		push @lines, "\t" . perl_quote($k) . ' => { ' . join(', ', @pairs) . ' }';
 3095: 	}
 3096: 
 3097: 	return join(",\n", @lines);
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3098: }
 3099: 
 3100: =head2 render_args_hash
 3101: 
 3102: Render a flat hashref into a Perl source-code argument list of the
 3103: form C<'key' => value, ...>, suitable for embedding in a function call
 3104: in a generated test file.
 3105: 
 3106:     my $code = render_args_hash({ type => 'string', min => 1 });
 3107:     # returns: "'min' => 1, 'type' => 'string'"
 3108: 
 3109: =head3 Arguments
 3110: 
 3111: =over 4
 3112: 
 3113: =item * C<$href>
 3114: 
 3115: A flat hashref of key-value pairs. Values may be scalars, arrayrefs,
 3116: or Regexp objects — all are handled by C<perl_quote>.
 3117: 
 3118: =back
 3119: 
 3120: =head3 Returns
 3121: 
 3122: A comma-separated string of C<key => value> pairs sorted by key.
 3123: Returns an empty string if C<$href> is undef, empty, or not a hashref.
 3124: 
 3125: =head3 Notes
 3126: 
 3127: Keys and values are both rendered via C<perl_quote>. In particular,
 3128: C<Regexp> values are rendered as C<qr{...}> which is correct for
 3129: L<Params::Validate::Strict> and L<Return::Set> schema arguments in
 3130: the generated test.
 3131: 
 3132: =head3 API specification
 3133: 
 3134: =head4 input
 3135: 
 3136:     { href => { type => 'any', optional => 1 } }
 3137: 
 3138: =head4 output
 3139: 
 3140:     { type => 'string' }
 3141: 
 3142: =cut
 3143: 
 3144: sub render_args_hash {
 3145: 	my $href = $_[0];
 3146: 
 3147: 	# Return empty string for absent or non-hash input
 3148: 	return '' unless $href && ref($href) eq 'HASH';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3149: 
 3150: 	# Sort keys for deterministic output across runs — important for
 3151: 	# generated test files that are committed to version control
 3152: 	my @pairs = map {
 3153: 		perl_quote($_) . ' => ' . perl_quote($href->{$_})
 3154: 	} sort keys %{$href};
 3155: 
 3156: 	return join(', ', @pairs);
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3157: }
 3158: 
 3159: =head2 render_arrayref_map
 3160: 
 3161: Render a hashref whose values are arrayrefs into a Perl source-code
 3162: fragment suitable for use as a hash literal in a generated test file.
 3163: 
 3164:     my $code = render_arrayref_map({ name => ['', 'a' x 100] });
 3165: 
 3166: =head3 Arguments
 3167: 
 3168: =over 4
 3169: 
 3170: =item * C<$href>
 3171: 
 3172: A hashref whose values are arrayrefs. Keys whose values are not
 3173: arrayrefs are silently skipped.
 3174: 
 3175: =back
 3176: 
 3177: =head3 Returns
 3178: 
 3179: A comma-separated string of C<'key' => [ val, ... ]> entries, one per
 3180: qualifying key, sorted alphabetically. Returns the string C<'()'> if
 3181: C<$href> is undef, empty, or not a hashref — this produces an empty
 3182: hash assignment in the generated test rather than a syntax error.
 3183: 
 3184: =head3 Notes
 3185: 
 3186: Array element values are rendered via C<perl_quote> which handles
 3187: scalars, arrayrefs, and Regexp objects. Non-arrayref values are
 3188: skipped without warning — this is intentional since callers may pass
 3189: mixed-value hashes and only want the arrayref entries rendered.
 3190: 
 3191: =head3 API specification
 3192: 
 3193: =head4 input
 3194: 
 3195:     { href => { type => 'any', optional => 1 } }
 3196: 
 3197: =head4 output
 3198: 
 3199:     { type => 'string' }
 3200: 
 3201: =cut
 3202: 
 3203: sub render_arrayref_map {
●3204 → 3212 → 3226 3204: 	my $href = $_[0];
 3205: 
 3206: 	# Return '()' rather than '' so callers get a valid empty hash
 3207: 	# literal rather than a syntax error in the generated test
 3208: 	return '()' unless $href && ref($href) eq 'HASH';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3209: 
 3210: 	my @entries;
 3211: 
 3212: 	for my $k (sort keys %{$href}) {
 3213: 		my $aref = $href->{$k};
 3214: 
 3215: 		# Skip non-arrayref values — mixed hashes are allowed by callers
 3216: 		next unless ref($aref) eq 'ARRAY';
 3217: 
 3218: 		# Render each array element via perl_quote so strings are
 3219: 		# properly quoted and numbers are left unquoted
 3220: 		my $vals = join(', ', map { perl_quote($_) } @{$aref});
 3221: 
 3222: 		# Use "\t" rather than a literal tab for clarity
 3223: 		push @entries, "\t" . perl_quote($k) . " => [ $vals ]";
 3224: 	}
 3225: 
 3226: 	return join(",\n", @entries);
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3227: }
 3228: 
 3229: # --------------------------------------------------
 3230: # _has_positions
 3231: #
 3232: # Purpose:    Determine whether any field in an input
 3233: #             spec hashref declares a positional argument
 3234: #             via the 'position' key.
 3235: #
 3236: # Entry:      $input_spec - the input section of a parsed
 3237: #             schema, expected to be a hashref whose values
 3238: #             are themselves hashrefs containing field specs.
 3239: #             May be undef or a non-hash ref.
 3240: #
 3241: # Exit:       Returns 1 if any field has a defined
 3242: #             'position' key, 0 otherwise.
 3243: #
 3244: # Notes:      Returns 0 immediately for undef or non-hash
 3245: #             input rather than throwing — callers use the
 3246: #             return value as a boolean and do not expect
 3247: #             exceptions from this function.
 3248: # --------------------------------------------------
 3249: sub _has_positions {
●3250 → 3255 → 3265 3250: 	my $input_spec = $_[0];
 3251: 
 3252: 	# Guard against undef or non-hash input — keys %$undef would throw
 3253: 	return 0 unless defined($input_spec) && ref($input_spec) eq 'HASH';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3254: 
 3255: 	for my $field (keys %{$input_spec}) {
 3256: 		# Only examine fields whose spec is a hashref — scalar specs
 3257: 		# (e.g. input: { type: string }) cannot have positions
 3258: 		next unless ref($input_spec->{$field}) eq 'HASH';
 3259: 
 3260: 		# Return immediately on first match — no need to scan further
 3261: 		return 1 if defined $input_spec->{$field}{position};
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3262: 	}
 3263: 
 3264: 	# No positional arguments found in any field
 3265: 	return 0;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3266: }
 3267: 
 3268: # --------------------------------------------------
 3269: # q_wrap
 3270: #
 3271: # Purpose:    Wrap a string in the most readable
 3272: #             q{} form that does not require escaping,
 3273: #             falling back to single-quoted form with
 3274: #             escaped apostrophes if no delimiter is
 3275: #             available.
 3276: #
 3277: # Entry:      $s - the string to wrap. May be undef.
 3278: # Exit:       Returns a Perl source-code fragment that
 3279: #             evaluates to the original string value,
 3280: #             or the string 'undef' if $s is undef.
 3281: #
 3282: # Notes:      index() returns -1 when not found and
 3283: #             any value >= 0 when found, including 0
 3284: #             for a delimiter at the start of the
 3285: #             string. We compare against $INDEX_NOT_FOUND
 3286: #             to make this boundary explicit and to
 3287: #             prevent off-by-one mutation survivors.
 3288: #             See GitHub issue #1.
 3289: # --------------------------------------------------
 3290: sub q_wrap {
●3291 → 3305 → 3314 3291: 	my $s = $_[0];
 3292: 
 3293: 	croak('q_wrap: argument must be a plain string, not a reference') if ref($s);
 3294: 
 3295: 	# Return empty string for undef — this function is a low-level
 3296: 	# string quoter only. Callers that need the Perl literal 'undef'
 3297: 	# for undefined values should use perl_quote() instead, which
 3298: 	# handles the undef -> 'undef' semantic conversion correctly.
 3299: 	# Returning '' here preserves the original behaviour and avoids
 3300: 	# injecting the bare word 'undef' into contexts that expect a
 3301: 	# quoted string value.
 3302: 	return "''" unless defined $s;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3303: 
 3304: 	# Try bracket-form q{} delimiters first — most readable
 3305: 	for my $p (@Q_BRACKET_PAIRS) {
 3306: 		my ($l, $r) = @{$p};
 3307: 
 3308: 		# Only use this bracket pair if neither bracket
 3309: 		# appears in the string — both must be checked
 3310: 		return "q$l$s$r" unless $s =~ /\Q$l\E|\Q$r\E/;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3311: 	}
 3312: 
 3313: 	# Try single-character delimiters in preference order
●3314 → 3314 → 3319 3314: 	for my $d (@Q_SINGLE_DELIMITERS) {
 3315: 		# index() returns $INDEX_NOT_FOUND (-1) when not found.
 3316: 		# Must use != $INDEX_NOT_FOUND rather than > 0 since
 3317: 		# the delimiter may legitimately appear at position 0
 3318: 		return "q$d$s$d" if index($s, $d) == $INDEX_NOT_FOUND;
  Mutants (Total: 3, Killed: 3, Survived: 0)
 3319: 	}
 3320: 
 3321: 	# Last resort — single-quoted string with escaped apostrophes
 3322: 	(my $esc = $s) =~ s/'/\\'/g;
 3323: 	return "'$esc'";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3324: }
 3325: 
 3326: # --------------------------------------------------
 3327: # perl_sq
 3328: #
 3329: # Purpose:    Escape a string for safe inclusion
 3330: #             inside a single-quoted Perl string
 3331: #             literal in generated test code.
 3332: #
 3333: # Entry:      $s - the string to escape.
 3334: # Exit:       Returns the escaped string, or an
 3335: #             empty string if $s is undef.
 3336: #
 3337: # Notes:      NUL byte replacement produces the
 3338: #             two-character sequence \0 which is
 3339: #             only correct when the result is used
 3340: #             inside a double-quoted string context
 3341: #             in the generated test.
 3342: #
 3343: #             The \b substitution (backspace) is
 3344: #             intentionally omitted — in Perl regex
 3345: #             context \b means word boundary, not
 3346: #             backspace, so substituting it here
 3347: #             would corrupt strings containing word
 3348: #             boundaries.
 3349: # --------------------------------------------------
 3350: sub perl_sq {
 3351: 	my $s = $_[0];
 3352: 
 3353: 	croak('perl_sq: argument must be a plain string, not a reference') if ref($s);
 3354: 
 3355: 	# Return empty string for undef — callers that need
 3356: 	# 'undef' literal should use perl_quote instead
 3357: 	return '' unless defined $s;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3358: 
 3359: 	# Escape backslashes first so later substitutions
 3360: 	# don't double-escape already-escaped sequences
 3361: 	$s =~ s/\\/\\\\/g;
 3362: 
 3363: 	# Escape apostrophes so they don't terminate the
 3364: 	# surrounding single-quoted string literal
 3365: 	$s =~ s/'/\\'/g;
 3366: 
 3367: 	# Escape common control characters to their
 3368: 	# printable two-character escape sequences
 3369: 	$s =~ s/\n/\\n/g;
 3370: 	$s =~ s/\r/\\r/g;
 3371: 	$s =~ s/\t/\\t/g;
 3372: 	$s =~ s/\f/\\f/g;
 3373: 
 3374: 	# Replace NUL bytes with \0 — valid only in
 3375: 	# double-quoted string context in generated code
 3376: 	$s =~ s/\0/\\0/g;
 3377: 
 3378: 	return $s;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3379: }
 3380: 
 3381: =head2 perl_quote
 3382: 
 3383: Convert any Perl value into a source-code fragment that reproduces that value
 3384: when evaluated in a generated test file.
 3385: 
 3386: =head3 Arguments
 3387: 
 3388: =over 4
 3389: 
 3390: =item * C<$v>
 3391: 
 3392: Any Perl value. May be undef, a scalar, an arrayref, a Regexp, or a blessed
 3393: object. All types are handled — undef becomes C<'undef'>, the strings
 3394: C<'true'>/C<'false'> become the Perl boolean constants C<!!1>/C<!!0>,
 3395: numbers are unquoted, other strings are single-quoted, arrayrefs recurse,
 3396: Regexps become C<qr{...}>, and anything else (including hashrefs and
 3397: blessed objects) falls through to C<render_fallback>.
 3398: 
 3399: =back
 3400: 
 3401: =head3 API specification
 3402: 
 3403: =head4 input
 3404: 
 3405:     { v => { type => 'any', optional => 1 } }
 3406: 
 3407: =head4 output
 3408: 
 3409:     { type => 'string' }
 3410: 
 3411: =cut
 3412: 
 3413: sub perl_quote {
 3414: 	my ($v) = @_;
 3415: 	return _perl_quote($v, 0);
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3416: }
 3417: 
 3418: sub _perl_quote {
●3419 → 3431 → 3455 3419: 	my ($v, $depth) = @_;
 3420: 	no warnings 'recursion';    ## no critic (TestingAndDebugging::ProhibitNoWarnings)
 3421: 	croak('perl_quote: structure too deeply nested (circular reference?)') if $depth > 100;
  Mutants (Total: 3, Killed: 3, Survived: 0)
 3422: 
 3423: 	# Undef produces the Perl literal 'undef'
 3424: 	return 'undef' unless defined $v;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3425: 
 3426: 	# Convert YAML boolean string literals to Perl
 3427: 	# boolean constants so they survive round-tripping
 3428: 	return '!!1' if $v eq 'true';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3429: 	return '!!0' if $v eq 'false';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3430: 
 3431: 	if(ref($v)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 3432: 		# Recursively quote each element of an arrayref
 3433: 		if(ref($v) eq 'ARRAY') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 3434: 			my @quoted_v = map { _perl_quote($_, $depth + 1) } @{$v};
 3435: 			return '[ ' . join(', ', @quoted_v) . ' ]';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3436: 		}
 3437: 
 3438: 		# Render Regexp objects as qr{} with modifiers
 3439: 		if(ref($v) eq 'Regexp') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 3440: 			my ($pat, $mods) = regexp_pattern($v);
 3441: 			my $re = "qr{$pat}";
 3442: 
 3443: 			# Append modifiers (e.g. 'i', 'x') if present
 3444: 			$re .= $mods if $mods;
 3445: 			return $re;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3446: 		}
 3447: 
 3448: 		# Hashrefs and other reference types fall through
 3449: 		# to render_fallback which uses Data::Dumper
 3450: 		return render_fallback($v);
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3451: 	}
 3452: 
 3453: 	# Numeric values are emitted unquoted so the generated
 3454: 	# test performs numeric rather than string comparison
 3455: 	return looks_like_number($v) ? $v : "'" . perl_sq($v) . "'";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3456: }
 3457: 
 3458: # --------------------------------------------------
 3459: # _generate_transform_properties
 3460: #
 3461: # Convert a hashref of transform
 3462: #     specifications into an arrayref of
 3463: #     LectroTest property definition hashrefs,
 3464: #     one per transform. Each hashref contains
 3465: #     all the information needed by
 3466: #     _render_properties to emit a runnable
 3467: #     Test::LectroTest property block.
 3468: #
 3469: # Entry:      $transforms  - hashref of transform name
 3470: #                            => transform spec, as
 3471: #                            loaded from the schema.
 3472: #             $function    - name of the function under
 3473: #                            test.
 3474: #             $module      - module name, or undef for
 3475: #                            builtin functions.
 3476: #             $input       - the top-level input spec
 3477: #                            hashref from the schema
 3478: #                            (used for position sorting).
 3479: #             $config      - the normalised config
 3480: #                            hashref, used to read
 3481: #                            properties.trials.
 3482: #             $new         - defined if the function is
 3483: #                            an object method; the value
 3484: #                            is not used here since
 3485: #                            property tests always
 3486: #                            construct a fresh object
 3487: #                            via new_ok() with no args.
 3488: #                            Presence vs absence is the
 3489: #                            only signal used.
 3490: #
 3491: # Exit:       Returns an arrayref of property hashrefs.
 3492: #             Returns an empty arrayref if no transforms
 3493: #             produce any testable properties.
 3494: #             Never returns undef.
 3495: #
 3496: # Notes:      Transforms whose input is the string
 3497: #             'undef' or whose input spec is not a
 3498: #             hashref are silently skipped — they
 3499: #             represent error-case transforms that have
 3500: #             no meaningful generator.
 3501: #
 3502: #             The 'WARN' vs 'WARNS' distinction in
 3503: #             _STATUS: the schema convention uses
 3504: #             'WARNS' throughout. This function checks
 3505: #             for 'WARNS' to match that convention.
 3506: # --------------------------------------------------
 3507: sub _generate_transform_properties {
●3508 → 3512 → 3656 3508: 	my ($transforms, $function, $module, $input, $config, $new) = @_;
 3509: 
 3510: 	my @properties;
 3511: 
 3512: 	for my $transform_name (sort keys %{$transforms}) {
 3513: 		# $transform_name is spliced by _render_properties as a Perl
 3514: 		# *variable name* (my $$transform_name = Property {...}), not
 3515: 		# just inside a string literal — reject anything that isn't
 3516: 		# identifier-shaped before it reaches that point.
 3517: 		_assert_identifier($transform_name, 'transform name');
 3518: 
 3519: 		my $transform   = $transforms->{$transform_name};
 3520: 
 3521: 		my $input_spec  = $transform->{input};
 3522: 
 3523: 		# Guard: skip transforms with no input or with the
 3524: 		# YAML scalar 'undef' as their input — these have no
 3525: 		# generator and cannot produce meaningful properties
 3526: 		if(!defined($input_spec) ||
  Mutants (Total: 1, Killed: 1, Survived: 0)
 3527: 		   (!ref($input_spec) && $input_spec eq 'undef')) {
 3528: 			next;
 3529: 		}
 3530: 
 3531: 		# Guard: skip transforms whose input is not a hashref —
 3532: 		# must come before the helper calls below so we never
 3533: 		# pass a non-hash to _detect_transform_properties or
 3534: 		# _process_custom_properties
 3535: 		next unless ref($input_spec) eq 'HASH';
 3536: 
 3537: 		# Default output spec to empty hash so _STATUS lookups
 3538: 		# below are always safe regardless of schema content
 3539: 		my $output_spec = $transform->{output} // {};
 3540: 
 3541: 		# Detect automatic properties from the transform spec
 3542: 		# (range constraints, type preservation, definedness)
 3543: 		my @detected_props = _detect_transform_properties(
 3544: 			$transform_name,
 3545: 			$input_spec,
 3546: 			$output_spec
 3547: 		);
 3548: 
 3549: 		# Process any custom properties defined in the schema
 3550: 		my @custom_props = ();
 3551: 		if(exists($transform->{properties}) &&

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_3551_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 3552: 		   ref($transform->{properties}) eq 'ARRAY') {
 3553: 			@custom_props = _process_custom_properties(
 3554: 				$transform->{properties},
 3555: 				$function,
 3556: 				$module,
 3557: 				$input_spec,
 3558: 				$output_spec,
 3559: 				$new
 3560: 			);
 3561: 		}
 3562: 
 3563: 		# Combine auto-detected and custom properties into one list
 3564: 		my @all_props = (@detected_props, @custom_props);
 3565: 
 3566: 		# Skip this transform if no properties were produced —
 3567: 		# nothing useful to render into the generated test
 3568: 		next unless @all_props;
 3569: 
 3570: 		# Build the LectroTest generator specification string,
 3571: 		# one entry per input field that has a generator
 3572: 		my @generators;
 3573: 		my @var_names;
 3574: 
 3575: 		for my $field (sort keys %{$input_spec}) {
 3576: 			my $spec = $input_spec->{$field};
 3577: 
 3578: 			# Skip non-hashref field specs — scalar types
 3579: 			# like 'string' have no generator sub-structure
 3580: 			next unless ref($spec) eq 'HASH';
 3581: 
 3582: 			# $field is spliced unescaped into the generated
 3583: 			# LectroTest generator spec by
 3584: 			# _schema_to_lectrotest_generator() — reject anything
 3585: 			# that isn't identifier-shaped first.
 3586: 			_assert_identifier($field, 'input field name');
 3587: 
 3588: 			my $gen = _schema_to_lectrotest_generator($field, $spec);
 3589: 			if(defined($gen) && length($gen)) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_3589_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 3590: 				push @generators, $gen;
 3591: 				push @var_names, $field;
 3592: 			}
 3593: 		}
 3594: 
 3595: 		my $gen_spec = join(', ', @generators);
 3596: 
 3597: 		# Build the call expression for the function under test.
 3598: 		# Note: property tests always construct a fresh object
 3599: 		# via new_ok() with no constructor arguments, regardless
 3600: 		# of what $new holds in the caller — the intent here is
 3601: 		# to test the method in isolation, not with specific
 3602: 		# construction state.
 3603: 		my $call_code;
 3604: 		if($module && defined($new)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 3605: 			# OO mode — construct a fresh object for each trial
 3606: 			$call_code  = "my \$obj = new_ok('$module');";
 3607: 			$call_code .= "\$obj->$function";
 3608: 		} elsif($module && $module ne $MODULE_BUILTIN) {
 3609: 			# Functional mode with a named module
 3610: 			$call_code = "$module\::$function";
 3611: 		} else {
 3612: 			# Builtin or unqualified function call
 3613: 			$call_code = $function;
 3614: 		}
 3615: 
 3616: 		# Build the argument list, respecting positional order
 3617: 		# if the input spec declares positions
 3618: 		my @args;
 3619: 		if(_has_positions($input_spec)) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_3619_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 3620: 			# Sort fields by declared position so the generated
 3621: 			# call passes arguments in the correct order
 3622: 			my @sorted = sort {
 3623: 				$input_spec->{$a}{position} <=>
 3624: 				$input_spec->{$b}{position}
 3625: 			} keys %{$input_spec};
 3626: 			@args = map { "\$$_" } @sorted;
 3627: 		} else {
 3628: 			# No positions — use alphabetical order from @var_names
 3629: 			@args = map { "\$$_" } @var_names;
 3630: 		}
 3631: 
 3632: 		my $args_str = join(', ', @args);
 3633: 
 3634: 		# Concatenate all property check expressions with &&
 3635: 		# so the generated property block passes only when
 3636: 		# every check holds
 3637: 		my @checks = map { $_->{code} } @all_props;
 3638: 		my $property_checks = join(" &&\n\t", @checks);
 3639: 
 3640: 		# Determine expected behaviour from output _STATUS.
 3641: 		# Note: the schema convention uses 'WARNS' not 'WARN'
 3642: 		my $should_die  = ($output_spec->{'_STATUS'} // '') eq 'DIES';
 3643: 		my $should_warn = ($output_spec->{'_STATUS'} // '') eq 'WARNS';
 3644: 
 3645: 		push @properties, {
 3646: 			name             => $transform_name,
 3647: 			generator_spec   => $gen_spec,
 3648: 			call_code        => "$call_code($args_str)",
 3649: 			property_checks  => $property_checks,
 3650: 			should_die       => $should_die,
 3651: 			should_warn      => $should_warn,
 3652: 			trials           => $config->{'properties'}{'trials'} // $DEFAULT_PROPERTY_TRIALS,
 3653: 		};
 3654: 	}
 3655: 
 3656: 	return \@properties;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3657: }
 3658: 
 3659: # --------------------------------------------------
 3660: # _get_semantic_generators
 3661: #
 3662: # Return a hashref of named semantic
 3663: #     generator definitions for use in
 3664: #     LectroTest property-based tests.
 3665: #     Each entry contains a 'code' key
 3666: #     holding a Gen {} block string and a
 3667: #     'description' key for documentation
 3668: #     and validation messages.
 3669: #
 3670: # Entry:      None.
 3671: #
 3672: # Exit:       Returns a hashref keyed by semantic
 3673: #             type name. Each value is a hashref
 3674: #             with 'code' and 'description' keys.
 3675: #
 3676: # Notes:      The returned hashref is built fresh
 3677: #             on every call — callers that need it
 3678: #             repeatedly should cache the result.
 3679: #             The 'code' strings are multi-line
 3680: #             Gen {} blocks; callers are responsible
 3681: #             for compressing whitespace before
 3682: #             embedding them in generated test files.
 3683: # --------------------------------------------------
 3684: sub _get_semantic_generators {
 3685: 	return {
 3686: 		email => {
 3687: 			code => q{
 3688: 				Gen {
 3689: 					my $len = 5 + int(rand(10));
 3690: 					my @addr;
 3691: 					my @tlds = qw(com org net edu gov io co uk de fr);
 3692: 
 3693: 					for(my $i = 0; $i < $len; $i++) {
 3694: 						push @addr, pack('c', (int(rand 26))+97);
 3695: 					}
 3696: 					push @addr, '@';
 3697: 					$len = 5 + int(rand(10));
 3698: 					for(my $i = 0; $i < $len; $i++) {
 3699: 						push @addr, pack('c', (int(rand 26))+97);
 3700: 					}
 3701: 					push @addr, '.';
 3702: 					$len = rand($#tlds+1);
 3703: 					push @addr, $tlds[$len];
 3704: 					return join('', @addr);
 3705: 				}
 3706: 			},
 3707: 			description => 'Valid email addresses',
 3708: 		}, url => {
 3709: 			code => q{
 3710: 				Gen {
 3711: 					my @schemes = qw(http https);
 3712: 					my @tlds = qw(com org net io);
 3713: 					my $scheme = $schemes[int(rand(@schemes))];
 3714: 					my $domain = join('', map { ('a'..'z')[int(rand(26))] } 1..(5 + int(rand(10))));
 3715: 					my $tld = $tlds[int(rand(@tlds))];
 3716: 					my $path = join('', map { ('a'..'z', '0'..'9', '-', '_')[int(rand(38))] } 1..int(rand(20)));
 3717: 
 3718: 					return "$scheme://$domain.$tld" . ($path ? "/$path" : '');
 3719: 				}
 3720: 			},
 3721: 			description => 'Valid HTTP/HTTPS URLs',
 3722: 		}, uuid => {
 3723: 			code => q{
 3724: 				Gen {
 3725: 					require UUID::Tiny;
 3726: 					UUID::Tiny::create_uuid_as_string(UUID::Tiny::UUID_V4());
 3727: 				}
 3728: 			},
 3729: 			description => 'Valid UUIDv4 identifiers',
 3730: 		}, phone_us => {
 3731: 			code => q{
 3732: 				Gen {
 3733: 					my $area = 200 + int(rand(800));
 3734: 					my $exchange = 200 + int(rand(800));
 3735: 					my $subscriber = int(rand(10000));
 3736: 					sprintf('%03d-%03d-%04d', $area, $exchange, $subscriber);
 3737: 				}
 3738: 			},
 3739: 			description => 'US phone numbers (XXX-XXX-XXXX format)',
 3740: 		}, phone_e164 => {
 3741: 			code => q{
 3742: 				Gen {
 3743: 					my $country = 1 + int(rand(999));
 3744: 					my $area = 100 + int(rand(900));
 3745: 					my $number = int(rand(10000000));
 3746: 					sprintf('+%d%03d%07d', $country, $area, $number);
 3747: 				}
 3748: 			},
 3749: 			description => 'E.164 international phone numbers',
 3750: 		}, ipv4 => {
 3751: 			code => q{
 3752: 				Gen {
 3753: 					join('.', map { int(rand(256)) } 1..4);
 3754: 				}
 3755: 			},
 3756: 			description => 'IPv4 addresses',
 3757: 		}, ipv6 => {
 3758: 			code => q{
 3759: 				Gen {
 3760: 					join(':', map { sprintf('%04x', int(rand(0x10000))) } 1..8);
 3761: 				}
 3762: 			},
 3763: 			description => 'IPv6 addresses',
 3764: 		}, username => {
 3765: 			code => q{
 3766: 				Gen {
 3767: 					my $len = 3 + int(rand(13));
 3768: 					my @chars = ('a'..'z', '0'..'9', '_', '-');
 3769: 					my $first = ('a'..'z')[int(rand(26))];
 3770: 					$first . join('', map { $chars[int(rand(@chars))] } 1..($len-1));
 3771: 				}
 3772: 			},
 3773: 			description => 'Valid usernames (alphanumeric with _ and -)',
 3774: 		}, slug => {
 3775: 			code => q{
 3776: 				Gen {
 3777: 					my @words = qw(quick brown fox jumps over lazy dog hello world test data);
 3778: 					my $count = 1 + int(rand(4));
 3779: 					join('-', map { $words[int(rand(@words))] } 1..$count);
 3780: 				}
 3781: 			},
 3782: 			description => 'URL slugs (lowercase words separated by hyphens)',
 3783: 		}, hex_color => {
 3784: 			code => q{
 3785: 				Gen {
 3786: 					sprintf('#%06x', int(rand(0x1000000)));
 3787: 				}
 3788: 			},
 3789: 			description => 'Hex color codes (#RRGGBB)',
 3790: 		}, iso_date => {
 3791: 			code => q{
 3792: 				Gen {
 3793: 					my $year = 2000 + int(rand(25));
 3794: 					my $month = 1 + int(rand(12));
 3795: 					my $day = 1 + int(rand(28));
 3796: 					sprintf('%04d-%02d-%02d', $year, $month, $day);
 3797: 				}
 3798: 			},
 3799: 			description => 'ISO 8601 date format (YYYY-MM-DD)',
 3800: 		},
 3801: 		iso_datetime => {
 3802: 			code => q{
 3803: 				Gen {
 3804: 					my $year = 2000 + int(rand(25));
 3805: 					my $month = 1 + int(rand(12));
 3806: 					my $day = 1 + int(rand(28));
 3807: 					my $hour = int(rand(24));
 3808: 					my $minute = int(rand(60));
 3809: 					my $second = int(rand(60));
 3810: 					sprintf('%04d-%02d-%02dT%02d:%02d:%02dZ',
 3811: 						$year, $month, $day, $hour, $minute, $second);
 3812: 				}
 3813: 			},
 3814: 			description => 'ISO 8601 datetime format (YYYY-MM-DDTHH:MM:SSZ)',
 3815: 		}, semver => {
 3816: 			code => q{
 3817: 				Gen {
 3818: 					my $major = int(rand(10));
 3819: 					my $minor = int(rand(20));
 3820: 					my $patch = int(rand(50));
 3821: 					"$major.$minor.$patch";
 3822: 				}
 3823: 			},
 3824: 			description => 'Semantic version strings (major.minor.patch)',
 3825: 		}, jwt => {
 3826: 			code => q{
 3827: 				Gen {
 3828: 					my @chars = ('A'..'Z', 'a'..'z', '0'..'9', '-', '_');
 3829: 					my $header    = join('', map { $chars[int(rand(@chars))] } 1..20);
 3830: 					my $payload   = join('', map { $chars[int(rand(@chars))] } 1..40);
 3831: 					my $signature = join('', map { $chars[int(rand(@chars))] } 1..30);
 3832: 					"$header.$payload.$signature";
 3833: 				}
 3834: 			},
 3835: 			description => 'JWT-like tokens (base64url format)',
 3836: 		}, json => {
 3837: 			code => q{
 3838: 				Gen {
 3839: 					my @keys = qw(id name value status count);
 3840: 					my $key = $keys[int(rand(@keys))];
 3841: 					my $value = 1 + int(rand(1000));
 3842: 					qq({"$key":$value});
 3843: 				}
 3844: 			},
 3845: 			description => 'Simple JSON objects',
 3846: 		}, base64 => {
 3847: 			code => q{
 3848: 				Gen {
 3849: 					my @chars = ('A'..'Z', 'a'..'z', '0'..'9', '+', '/');
 3850: 					my $len = 12 + int(rand(20));
 3851: 					my $str = join('', map { $chars[int(rand(@chars))] } 1..$len);
 3852: 					$str .= '=' x (4 - ($len % 4)) if $len % 4;
 3853: 					$str;
 3854: 				}
 3855: 			},
 3856: 			description => 'Base64-encoded strings',
 3857: 		}, md5 => {
 3858: 			code => q{
 3859: 				Gen {
 3860: 					join('', map { sprintf('%x', int(rand(16))) } 1..32);
 3861: 				}
 3862: 			},
 3863: 			description => 'MD5 hashes (32 hex characters)',
 3864: 		}, sha256 => {
 3865: 			code => q{
 3866: 				Gen {
 3867: 					join('', map { sprintf('%x', int(rand(16))) } 1..64);
 3868: 				}
 3869: 			},
 3870: 			description => 'SHA-256 hashes (64 hex characters)',
 3871: 		}, unix_timestamp => {
 3872: 			code => q{
 3873: 				Gen {
 3874: 					time;
 3875: 				}
 3876: 			},
 3877: 			description => 'Unix timestamps (seconds since epoch)',
 3878: 		},
 3879: 	};
 3880: }
 3881: 
 3882: # --------------------------------------------------
 3883: # _get_builtin_properties
 3884: #
 3885: # Purpose:    Return a hashref of named built-in
 3886: #             property templates that can be
 3887: #             referenced by name in a transform's
 3888: #             'properties' list in the schema.
 3889: #             Each entry contains a 'description'
 3890: #             string, a 'code_template' coderef, and
 3891: #             an 'applicable_to' arrayref.
 3892: #
 3893: # Entry:      None.
 3894: #
 3895: # Exit:       Returns a hashref keyed by property
 3896: #             name. Each value is a hashref with
 3897: #             'description', 'code_template', and
 3898: #             'applicable_to' keys.
 3899: #
 3900: # Notes:      'applicable_to' lists the types for
 3901: #             which each property is meaningful. It
 3902: #             is stored for documentation purposes
 3903: #             and potential future filtering — it is
 3904: #             not currently enforced by any caller.
 3905: #
 3906: #             Each 'code_template' coderef receives
 3907: #             three arguments: ($function, $call_code,
 3908: #             $input_vars). Most templates use only
 3909: #             $call_code; $function and $input_vars
 3910: #             are provided for templates that need
 3911: #             them (e.g. idempotent, length_preserved,
 3912: #             preserves_keys).
 3913: #
 3914: #             'monotonic_increasing' has been
 3915: #             intentionally omitted. A correct
 3916: #             implementation requires calling the
 3917: #             function twice with ordered inputs,
 3918: #             which the current single-call property
 3919: #             framework does not support. A
 3920: #             placeholder that unconditionally returns
 3921: #             true would give false confidence and has
 3922: #             therefore been removed.
 3923: # --------------------------------------------------
 3924: sub _get_builtin_properties {
 3925: 	return {
 3926: 		idempotent => {
 3927: 			description   => 'Function is idempotent: f(f(x)) == f(x)',
 3928: 			code_template => sub {
 3929: 				my ($function, $call_code, $input_vars) = @_;
 3930: 
 3931: 				# String comparison works for all scalar types in Perl —
 3932: 				# numeric values stringify consistently for eq
 3933: 				return "do { my \$tmp = $call_code; \$result eq \$tmp }";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3934: 			},
 3935: 			applicable_to => ['all'],
 3936: 		}, non_negative => {
 3937: 			description   => 'Result is always non-negative',
 3938: 			code_template => sub {
 3939: 				my ($function, $call_code, $input_vars) = @_;
 3940: 				return '$result >= 0';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3941: 			},
 3942: 			applicable_to => ['number', 'integer', 'float'],
 3943: 		}, positive => {
 3944: 			description   => 'Result is always positive (> 0)',
 3945: 			code_template => sub {
 3946: 				my ($function, $call_code, $input_vars) = @_;
 3947: 				return '$result > 0';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3948: 			},
 3949: 			applicable_to => ['number', 'integer', 'float'],
 3950: 		}, non_empty => {
 3951: 			description   => 'Result is never empty',
 3952: 			code_template => sub {
 3953: 				my ($function, $call_code, $input_vars) = @_;
 3954: 				return 'length($result) > 0';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3955: 			},
 3956: 			applicable_to => ['string'],
 3957: 		},
 3958: 
 3959: 		length_preserved => {
 3960: 			description   => 'Output length equals input length',
 3961: 			code_template => sub {
 3962: 				my ($function, $call_code, $input_vars) = @_;
 3963: 				my $first_var = $input_vars->[0];
 3964: 				return "length(\$result) == length(\$$first_var)";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3965: 			},
 3966: 			applicable_to => ['string'],
 3967: 		},
 3968: 
 3969: 		uppercase => {
 3970: 			description   => 'Result is all uppercase',
 3971: 			code_template => sub {
 3972: 				my ($function, $call_code, $input_vars) = @_;
 3973: 				return '$result eq uc($result)';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3974: 			},
 3975: 			applicable_to => ['string'],
 3976: 		},
 3977: 
 3978: 		lowercase => {
 3979: 			description   => 'Result is all lowercase',
 3980: 			code_template => sub {
 3981: 				my ($function, $call_code, $input_vars) = @_;
 3982: 				return '$result eq lc($result)';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3983: 			},
 3984: 			applicable_to => ['string'],
 3985: 		},
 3986: 
 3987: 		trimmed => {
 3988: 			description   => 'Result has no leading or trailing whitespace',
 3989: 			code_template => sub {
 3990: 				my ($function, $call_code, $input_vars) = @_;
 3991: 				return '$result !~ /^\s/ && $result !~ /\s$/';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3992: 			},
 3993: 			applicable_to => ['string'],
 3994: 		},
 3995: 
 3996: 		sorted_ascending => {
 3997: 			description   => 'Array is sorted in ascending order',
 3998: 			code_template => sub {
 3999: 				my ($function, $call_code, $input_vars) = @_;
 4000: 				return 'do { my @arr = @$result; my $sorted = 1; ' .
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4001: 					'for my $i (1..$#arr) { $sorted = 0 if $arr[$i] < $arr[$i-1]; } ' .
 4002: 					'$sorted }';
 4003: 			},
 4004: 			applicable_to => ['arrayref'],
 4005: 		},
 4006: 
 4007: 		sorted_descending => {
 4008: 			description   => 'Array is sorted in descending order',
 4009: 			code_template => sub {
 4010: 				my ($function, $call_code, $input_vars) = @_;
 4011: 				return 'do { my @arr = @$result; my $sorted = 1; ' .
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4012: 					'for my $i (1..$#arr) { $sorted = 0 if $arr[$i] > $arr[$i-1]; } ' .
 4013: 					'$sorted }';
 4014: 			},
 4015: 			applicable_to => ['arrayref'],
 4016: 		},
 4017: 
 4018: 		unique_elements => {
 4019: 			description   => 'Array has no duplicate elements',
 4020: 			code_template => sub {
 4021: 				my ($function, $call_code, $input_vars) = @_;
 4022: 				return 'do { my @arr = @$result; my %seen; !grep { $seen{$_}++ } @arr }';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4023: 			},
 4024: 			applicable_to => ['arrayref'],
 4025: 		},
 4026: 
 4027: 		preserves_keys => {
 4028: 			description   => 'Hash has same keys as input',
 4029: 			code_template => sub {
 4030: 				my ($function, $call_code, $input_vars) = @_;
 4031: 				my $first_var = $input_vars->[0];
 4032: 				return 'do { my @in  = sort keys %{$' . $first_var . '}; ' .
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4033: 					'my @out = sort keys %$result; ' .
 4034: 					'join(",", @in) eq join(",", @out) }';
 4035: 			},
 4036: 			applicable_to => ['hashref'],
 4037: 		},
 4038: 	};
 4039: }
 4040: 
 4041: # --------------------------------------------------
 4042: # _schema_to_lectrotest_generator
 4043: #
 4044: # Purpose:    Convert a single schema field spec
 4045: #             hashref into a LectroTest generator
 4046: #             declaration string of the form
 4047: #             '$field <- Generator(...)'.
 4048: #             Used to build the ##[ ... ]## generator
 4049: #             block inside a Property definition.
 4050: #
 4051: # Entry:      $field_name - the parameter name as it
 4052: #                           will appear in the
 4053: #                           generated test code.
 4054: #             $spec       - hashref containing at
 4055: #                           minimum a 'type' key.
 4056: #                           May also contain 'min',
 4057: #                           'max', 'semantic', and
 4058: #                           'matches' keys depending
 4059: #                           on type.
 4060: #
 4061: # Exit:       Returns a string of the form
 4062: #             '$field <- Generator(...)' on success.
 4063: #             Returns undef if the spec is not a
 4064: #             hashref or if range constraints are
 4065: #             invalid (min >= max for numeric types).
 4066: #             Returns a String generator with a carp
 4067: #             warning for unknown types.
 4068: #
 4069: # Side effects: Carps on unknown semantic types,
 4070: #               invalid numeric ranges, and unknown
 4071: #               field types.
 4072: #
 4073: # Notes:      Semantic generators are checked first
 4074: #             for string fields and take precedence
 4075: #             over the regular string generator.
 4076: #             The $input_spec parameter in the type-
 4077: #             detection helpers is reserved for future
 4078: #             use and is currently unused.
 4079: # --------------------------------------------------
 4080: sub _schema_to_lectrotest_generator {
●4081 → 4094 → 4118 4081: 	my ($field_name, $spec) = @_;
 4082: 
 4083: 	# Guard: must be a hashref to dereference safely
 4084: 	return unless defined($spec) && ref($spec) eq 'HASH';
 4085: 
 4086: 	# Default to string when no type is declared
 4087: 	my $type = $spec->{'type'} || $DEFAULT_FIELD_TYPE;
 4088: 
 4089: 	# --------------------------------------------------
 4090: 	# Semantic generators take precedence for string
 4091: 	# fields — they produce realistic domain-specific
 4092: 	# values rather than random character sequences
 4093: 	# --------------------------------------------------
 4094: 	if($type eq 'string' && defined($spec->{'semantic'})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4095: 		my $semantic_type = $spec->{'semantic'};
 4096: 		my $generators    = _get_semantic_generators();
 4097: 
 4098: 		if(exists($generators->{$semantic_type})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4099: 			my $gen_code = $generators->{$semantic_type}{'code'};
 4100: 
 4101: 			# Compress the multi-line generator code into a
 4102: 			# single line for embedding in the ##[ ]## block
 4103: 			$gen_code =~ s/^\s+//;
 4104: 			$gen_code =~ s/\s+$//;
 4105: 			$gen_code =~ s/\n\s+/ /g;
 4106: 
 4107: 			return "$field_name <- $gen_code";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4108: 		} else {
 4109: 			carp "Unknown semantic type '$semantic_type', " .
 4110: 				"falling back to regular string generator";
 4111: 			# Fall through to regular string generation below
 4112: 		}
 4113: 	}
 4114: 
 4115: 	# --------------------------------------------------
 4116: 	# Integer generator
 4117: 	# --------------------------------------------------
●4118 → 4118 → 4141 4118: 	if($type eq 'integer') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4119: 		my $min = $spec->{'min'};
 4120: 		my $max = $spec->{'max'};
 4121: 
 4122: 		if(!defined($min) && !defined($max)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4123: 			# Unconstrained — use LectroTest's built-in Int
 4124: 			return "$field_name <- Int";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4125: 		} elsif(!defined($min)) {
 4126: 			# Only max defined — generate 0 to max
 4127: 			return "$field_name <- Int(sized => sub { int(rand($max + 1)) })";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4128: 		} elsif(!defined($max)) {
 4129: 			# Only min defined — generate min to min + range
 4130: 			return "$field_name <- Int(sized => sub { $min + int(rand($DEFAULT_GENERATOR_RANGE)) })";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4131: 		} else {
 4132: 			# Both defined — generate within [min, max]
 4133: 			my $range = $max - $min;
 4134: 			return "$field_name <- Int(sized => sub { $min + int(rand($range + 1)) })";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4135: 		}
 4136: 	}
 4137: 
 4138: 	# --------------------------------------------------
 4139: 	# Float / number generator
 4140: 	# --------------------------------------------------
●4141 → 4141 → 4191 4141: 	if($type eq 'number' || $type eq 'float') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4142: 		my $min = $spec->{'min'};
 4143: 		my $max = $spec->{'max'};
 4144: 
 4145: 		if(!defined($min) && !defined($max)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4146: 			# Unconstrained — symmetric range around zero
 4147: 			return "$field_name <- Float(sized => sub { rand($DEFAULT_GENERATOR_RANGE) - $DEFAULT_GENERATOR_RANGE / 2 })";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4148: 
 4149: 		} elsif(!defined($min)) {
 4150: 			# Only max defined — choose range based on sign of max
 4151: 			if($max == $ZERO_BOUNDARY) {
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4152: 				# max=0: negative numbers only
 4153: 				return "$field_name <- Float(sized => sub { -rand($DEFAULT_GENERATOR_RANGE) })";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4154: 			} elsif($max > $ZERO_BOUNDARY) {
  Mutants (Total: 3, Killed: 3, Survived: 0)
 4155: 				# Positive max: generate 0 to max
 4156: 				return "$field_name <- Float(sized => sub { rand($max) })";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4157: 			} else {
 4158: 				# Negative max: generate from (max - range) to max
 4159: 				return "$field_name <- Float(sized => sub { ($max - $DEFAULT_GENERATOR_RANGE) + rand($DEFAULT_GENERATOR_RANGE + $max) })";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4160: 			}
 4161: 
 4162: 		} elsif(!defined($max)) {
 4163: 			# Only min defined — choose range based on sign of min
 4164: 			if($min == $ZERO_BOUNDARY) {
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4165: 				# min=0: positive numbers only
 4166: 				return "$field_name <- Float(sized => sub { rand($DEFAULT_GENERATOR_RANGE) })";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4167: 			} elsif($min > $ZERO_BOUNDARY) {

					

					
Mutants (Total: 3, Killed: 0, Survived: 3)
					

				
NUM_BOUNDARY_4167_17_<: Numeric boundary flip > to <
HIGH: Likely missing edge-case test (boundary value)

								

								
🧪 Suggested Test
								
# Boundary test suggestion
is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );

								
							
NUM_BOUNDARY_4167_17_>=: Numeric boundary flip > to >=
HIGH: Likely missing edge-case test (boundary value)

								

								
🧪 Suggested Test
								
# Boundary test suggestion
is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );

								
							
NUM_BOUNDARY_4167_17_<=: Numeric boundary flip > to <=
HIGH: Likely missing edge-case test (boundary value)

								

								
🧪 Suggested Test
								
# Boundary test suggestion
is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );

								
							
 4168: 				# Positive min: generate min to min + range
 4169: 				return "$field_name <- Float(sized => sub { $min + rand($DEFAULT_GENERATOR_RANGE) })";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4170: 			} else {
 4171: 				# Negative min: generate from min to min + range
 4172: 				return "$field_name <- Float(sized => sub { $min + rand(-$min + $DEFAULT_GENERATOR_RANGE) })";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4173: 			}
 4174: 
 4175: 		} else {
 4176: 			# Both min and max defined — validate then generate
 4177: 			my $range = $max - $min;
 4178: 			if($range <= $ZERO_BOUNDARY) {
  Mutants (Total: 4, Killed: 4, Survived: 0)
 4179: 				carp "Invalid range for '$field_name': min=$min, max=$max";
 4180: 				# Return undef rather than emitting a degenerate
 4181: 				# generator that would silently produce wrong values
 4182: 				return;
 4183: 			}
 4184: 			return "$field_name <- Float(sized => sub { $min + rand($range) })";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4185: 		}
 4186: 	}
 4187: 
 4188: 	# --------------------------------------------------
 4189: 	# String generator
 4190: 	# --------------------------------------------------
●4191 → 4191 → 4230 4191: 	if($type eq 'string') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4192: 		my $min_len = $spec->{'min'} // 0;
 4193: 		my $max_len = $spec->{'max'} // $DEFAULT_MAX_STRING_LEN;
 4194: 
 4195: 		# If a regex pattern is declared, delegate to
 4196: 		# Data::Random::String::Matches for pattern-aware generation
 4197: 		if(defined($spec->{'matches'})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4198: 			my $pattern = $spec->{'matches'};
 4199: 
 4200: 			# Compile the pattern safely rather than splicing the raw
 4201: 			# string into qr/$pattern/ — the raw form lets a pattern
 4202: 			# containing an unescaped '/' break out of the qr//
 4203: 			# delimiter and inject arbitrary Perl into the generated
 4204: 			# test. regexp_pattern() decomposes the already-compiled
 4205: 			# Regexp object back into pattern text that is guaranteed
 4206: 			# to be a self-contained regex body, safe to re-embed.
 4207: 			my $compiled = ref($pattern) eq 'Regexp' ? $pattern : eval { qr/$pattern/ };
 4208: 			if($@ || !defined($compiled)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4209: 				carp "Invalid matches pattern '$pattern' for field '$field_name': $@";
 4210: 				return "$field_name <- String(length => [$min_len, $max_len])";

					

					
Mutants (Total: 2, Killed: 0, Survived: 2)
					

				
BOOL_NEGATE_4210_5: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes

								

								
🧪 Suggested Test
								
# Boolean branch test suggestion
ok( !func(INPUT), 'Verify boolean branch behaviour' );

								
							
RETURN_UNDEF_4210_5: Replace return expression with undef
LOW: Mutation survived, but impact may be minor

								

								
🧪 Suggested Test
								
# Return value assertion
is( func(INPUT), EXPECTED, 'Verify correct return value' );

								
							
 4211: 			}
 4212: 			my ($pat, $mods) = regexp_pattern($compiled);
 4213: 			my $safe_re = "qr{$pat}" . ($mods // '');
 4214: 
 4215: 			if(defined($spec->{'max'})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4216: 				return "$field_name <- Gen { Data::Random::String::Matches->create_random_string({ regex => $safe_re, length => $spec->{'max'} }) }";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4217: 			} elsif(defined($spec->{'min'})) {
 4218: 				return "$field_name <- Gen { Data::Random::String::Matches->create_random_string({ regex => $safe_re, length => $spec->{'min'} }) }";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4219: 			} else {
 4220: 				return "$field_name <- Gen { Data::Random::String::Matches->create_random_string({ regex => $safe_re }) }";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4221: 			}
 4222: 		}
 4223: 
 4224: 		return "$field_name <- String(length => [$min_len, $max_len])";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4225: 	}
 4226: 
 4227: 	# --------------------------------------------------
 4228: 	# Boolean generator
 4229: 	# --------------------------------------------------
●4230 → 4230 → 4237 4230: 	if($type eq 'boolean') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4231: 		return "$field_name <- Bool";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4232: 	}
 4233: 
 4234: 	# --------------------------------------------------
 4235: 	# Arrayref generator
 4236: 	# --------------------------------------------------
●4237 → 4237 → 4248 4237: 	if($type eq 'arrayref') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4238: 		my $min_size = $spec->{'min'} // 0;
 4239: 		my $max_size = $spec->{'max'} // $DEFAULT_MAX_COLLECTION_SIZE;
 4240: 		return "$field_name <- List(Int, length => [$min_size, $max_size])";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4241: 	}
 4242: 
 4243: 	# --------------------------------------------------
 4244: 	# Hashref generator
 4245: 	# LectroTest has no built-in Hash generator so we
 4246: 	# use Elements over a pre-built list of hashrefs
 4247: 	# --------------------------------------------------
●4248 → 4248 → 4257 4248: 	if($type eq 'hashref') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4249: 		my $min_keys = $spec->{'min'} // 0;
 4250: 		my $max_keys = $spec->{'max'} // $DEFAULT_MAX_COLLECTION_SIZE;
 4251: 		return "$field_name <- Elements(map { my \%h; for (1..\$_) { \$h{'key'.\$_} = \$_ }; \\\%h } $min_keys..$max_keys)";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4252: 	}
 4253: 
 4254: 	# --------------------------------------------------
 4255: 	# Unknown type — fall back to String with a warning
 4256: 	# --------------------------------------------------
 4257: 	carp "Unknown type '$type' for '$field_name' LectroTest generator, using String";
 4258: 	return "$field_name <- String";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4259: }
 4260: 
 4261: # --------------------------------------------------
 4262: # _is_numeric_transform
 4263: #
 4264: # Determine whether a transform's output
 4265: #     spec declares a numeric type, indicating
 4266: #     that numeric range properties should be
 4267: #     generated for it.
 4268: #
 4269: # Entry:      $input_spec  - the transform's input
 4270: #                            spec hashref. Currently
 4271: #                            unused; reserved for
 4272: #                            future input-type checks.
 4273: #             $output_spec - the transform's output
 4274: #                            spec hashref.
 4275: #
 4276: # Exit:       Returns 1 if the output type is one of
 4277: #             'number', 'integer', or 'float'.
 4278: #             Returns 0 otherwise.
 4279: # --------------------------------------------------
 4280: sub _is_numeric_transform {
 4281: 	my ($input_spec, $output_spec) = @_;
 4282: 
 4283: 	# $input_spec is currently unused — reserved for future
 4284: 	# input-side type checking when detecting mixed transforms
 4285: 	my $out_type = ($output_spec // {})->{'type'} // '';
 4286: 
 4287: 	return($out_type eq 'number' || $out_type eq 'integer' || $out_type eq 'float');
 4288: }
 4289: 
 4290: # --------------------------------------------------
 4291: # _is_string_transform
 4292: #
 4293: # Purpose:    Determine whether a transform's output
 4294: #             spec declares a string type, indicating
 4295: #             that string length and pattern properties
 4296: #             should be generated for it.
 4297: #
 4298: # Entry:      $input_spec  - the transform's input
 4299: #                            spec hashref. Currently
 4300: #                            unused; reserved for
 4301: #                            future input-type checks.
 4302: #             $output_spec - the transform's output
 4303: #                            spec hashref.
 4304: #
 4305: # Exit:       Returns 1 if the output type is 'string'.
 4306: #             Returns 0 otherwise.
 4307: # --------------------------------------------------
 4308: sub _is_string_transform {
 4309: 	my ($input_spec, $output_spec) = @_;
 4310: 
 4311: 	# $input_spec is currently unused — reserved for future
 4312: 	# input-side type checking when detecting mixed transforms
 4313: 	my $out_type = ($output_spec // {})->{'type'} // '';
 4314: 
 4315: 	return($out_type eq 'string');
 4316: }
 4317: 
 4318: # --------------------------------------------------
 4319: # _same_type
 4320: #
 4321: # Purpose:    Determine whether the dominant type of
 4322: #             a transform's input and output specs
 4323: #             match, indicating that type-preservation
 4324: #             properties are meaningful.
 4325: #
 4326: # Entry:      $input_spec  - the transform's input
 4327: #                            spec hashref, or a nested
 4328: #                            multi-field hashref.
 4329: #             $output_spec - the transform's output
 4330: #                            spec hashref.
 4331: #
 4332: # Exit:       Returns 1 if the dominant input and
 4333: #             output types are identical strings.
 4334: #             Returns 0 otherwise.
 4335: #
 4336: # Notes:      Uses _get_dominant_type for both sides.
 4337: #             For multi-field input specs, dominant
 4338: #             type is the type of the first field
 4339: #             encountered — this is a simplification.
 4340: #             TODO: extend to handle mixed-type inputs
 4341: #             by checking all fields, not just the
 4342: #             first one found.
 4343: # --------------------------------------------------
 4344: sub _same_type {
 4345: 	my ($input_spec, $output_spec) = @_;
 4346: 
 4347: 	# Guard: treat missing specs as untyped — two untyped
 4348: 	# specs both default to $DEFAULT_FIELD_TYPE and would
 4349: 	# compare equal, which is intentionally conservative
 4350: 	my $in_type  = _get_dominant_type($input_spec  // {});
 4351: 	my $out_type = _get_dominant_type($output_spec // {});
 4352: 
 4353: 	return($in_type eq $out_type);
 4354: }
 4355: 
 4356: # --------------------------------------------------
 4357: # _get_dominant_type
 4358: #
 4359: # Purpose:    Extract the most representative type
 4360: #             string from a spec hashref. For flat
 4361: #             output specs this is simply the 'type'
 4362: #             key. For multi-field input specs it is
 4363: #             the type of the first sub-field found
 4364: #             that declares one.
 4365: #
 4366: # Entry:      $spec - a spec hashref. May be a flat
 4367: #                     output spec ({ type => '...' })
 4368: #                     or a multi-field input spec
 4369: #                     ({ field => { type => '...' } }).
 4370: #                     May be undef or empty.
 4371: #
 4372: # Exit:       Returns a type string. Returns
 4373: #             $DEFAULT_FIELD_TYPE ('string') if no
 4374: #             type can be determined.
 4375: # --------------------------------------------------
 4376: sub _get_dominant_type {
●4377 → 4388 → 4395 4377: 	my $spec = $_[0];
 4378: 
 4379: 	# Guard: return default for undef or non-hash input
 4380: 	return $DEFAULT_FIELD_TYPE
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4381: 		unless defined($spec) && ref($spec) eq 'HASH';
 4382: 
 4383: 	# Flat spec — type declared directly
 4384: 	return $spec->{'type'} if defined($spec->{'type'});
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4385: 
 4386: 	# Multi-field spec — return the type of the first
 4387: 	# sub-field that declares one
 4388: 	for my $field (keys %{$spec}) {
 4389: 		next unless ref($spec->{$field}) eq 'HASH';
 4390: 		return $spec->{$field}{'type'}
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4391: 			if defined($spec->{$field}{'type'});
 4392: 	}
 4393: 
 4394: 	# No type found anywhere — return the safe default
 4395: 	return $DEFAULT_FIELD_TYPE;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4396: }
 4397: 
 4398: # --------------------------------------------------
 4399: # _render_properties
 4400: #
 4401: # Purpose:    Render an arrayref of property definition
 4402: #             hashrefs (as produced by
 4403: #             _generate_transform_properties) into a
 4404: #             string of Perl source code suitable for
 4405: #             embedding in a generated test file.
 4406: #             The output uses Test::LectroTest::Compat
 4407: #             to run each property as a holds() check.
 4408: #
 4409: # Entry:      $properties - arrayref of property
 4410: #             hashrefs, each containing: name,
 4411: #             generator_spec, call_code,
 4412: #             property_checks, should_die,
 4413: #             should_warn, trials.
 4414: #             May be undef or an empty arrayref.
 4415: #
 4416: # Exit:       Returns a string of Perl source code.
 4417: #             Returns an empty string if $properties
 4418: #             is undef, not an arrayref, or empty.
 4419: #
 4420: # Notes:      The generated code uses 4-space
 4421: #             indentation deliberately — this is the
 4422: #             indentation style of the generated test
 4423: #             file, not of this module. Tabs are used
 4424: #             in this module's own source; spaces are
 4425: #             emitted into generated output for
 4426: #             readability of the produced test files.
 4427: # --------------------------------------------------
 4428: sub _render_properties {
●4429 → 4438 → 4465 4429: 	my $properties = $_[0];
 4430: 
 4431: 	# Return empty string for absent or non-array input —
 4432: 	# callers treat '' as no property block to emit
 4433: 	return '' unless defined($properties) && ref($properties) eq 'ARRAY';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4434: 	return '' unless @{$properties};
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4435: 
 4436: 	my $code = "use_ok('Test::LectroTest::Compat');\n\n";
 4437: 
 4438: 	for my $prop (@{$properties}) {
 4439: 		# Emit a labelled Property block for each transform property
 4440: 		$code .= "# Transform property: $prop->{'name'}\n";
 4441: 		$code .= "my \$$prop->{'name'} = Property {\n";
 4442: 		$code .= "    ##[ $prop->{'generator_spec'} ]##\n";
 4443: 		$code .= "    \n";
 4444: 		$code .= "    my \$result = eval { $prop->{'call_code'} };\n";
 4445: 
 4446: 		if($prop->{'should_die'}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4447: 			# For transforms that expect death, pass if the
 4448: 			# eval caught an exception
 4449: 			$code .= "    my \$died = defined(\$\@) && \$\@;\n";
 4450: 			$code .= "    \$died;\n";
 4451: 		} else {
 4452: 			# For normal transforms, pass only if no exception
 4453: 			# was thrown and all property checks hold
 4454: 			$code .= "    my \$error = \$\@;\n";
 4455: 			$code .= "    \n";
 4456: 			$code .= "    !\$error && (\n";
 4457: 			$code .= "        $prop->{'property_checks'}\n";
 4458: 			$code .= "    );\n";
 4459: 		}
 4460: 
 4461: 		$code .= "}, name => '$prop->{'name'}', trials => $prop->{'trials'};\n\n";
 4462: 		$code .= "holds(\$$prop->{'name'});\n";
 4463: 	}
 4464: 
 4465: 	return $code;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4466: }
 4467: 
 4468: # --------------------------------------------------
 4469: # _detect_transform_properties
 4470: #
 4471: # Purpose:    Automatically derive a list of testable
 4472: #             LectroTest property hashrefs from a
 4473: #             transform's input and output specs.
 4474: #             Detects numeric range constraints, exact
 4475: #             value matches, string length constraints,
 4476: #             type preservation, and definedness.
 4477: #
 4478: # Entry:      $transform_name - string name of the
 4479: #                               transform, used for
 4480: #                               heuristic matching
 4481: #                               (e.g. 'positive').
 4482: #             $input_spec     - the transform's input
 4483: #                               hashref, or the string
 4484: #                               'undef'.
 4485: #             $output_spec    - the transform's output
 4486: #                               hashref, or undef if
 4487: #                               absent.
 4488: #
 4489: # Exit:       Returns a list of property hashrefs,
 4490: #             each containing 'name' and 'code' keys.
 4491: #             Returns an empty list if no properties
 4492: #             can be detected or if $input_spec is
 4493: #             undef or the string 'undef'.
 4494: #
 4495: # Notes:      The 'positive' heuristic checks the
 4496: #             transform name case-insensitively against
 4497: #             $TRANSFORM_POSITIVE_PATTERN and adds a
 4498: #             non-negative constraint if matched.
 4499: #             This is intentionally a rough heuristic
 4500: #             rather than a precise semantic check.
 4501: # --------------------------------------------------
 4502: sub _detect_transform_properties {
●4503 → 4518 → 4548 4503: 	my ($transform_name, $input_spec, $output_spec) = @_;
 4504: 
 4505: 	my @properties;
 4506: 
 4507: 	# Guard: skip undef input and the YAML scalar 'undef'
 4508: 	return @properties unless defined($input_spec);
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4509: 	return @properties if(!ref($input_spec) && $input_spec eq 'undef');
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4510: 
 4511: 	# Default output spec to empty hash so all key lookups
 4512: 	# below are safe regardless of what the schema provides
 4513: 	$output_spec //= {};
 4514: 
 4515: 	# --------------------------------------------------
 4516: 	# Property 1: Output range constraints (numeric)
 4517: 	# --------------------------------------------------
 4518: 	if(_is_numeric_transform($input_spec, $output_spec)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4519: 		if(defined($output_spec->{'min'})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4520: 			my $min = $output_spec->{'min'};
 4521: 			push @properties, {
 4522: 				name => 'min_constraint',
 4523: 				code => "defined(\$result) && looks_like_number(\$result) && \$result >= $min",
 4524: 			};
 4525: 		}
 4526: 
 4527: 		if(defined($output_spec->{'max'})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4528: 			my $max = $output_spec->{'max'};
 4529: 			push @properties, {
 4530: 				name => 'max_constraint',
 4531: 				code => "defined(\$result) && looks_like_number(\$result) && \$result <= $max",
 4532: 			};
 4533: 		}
 4534: 
 4535: 		# Heuristic: transforms named 'positive' (case-insensitive)
 4536: 		# imply a non-negative result constraint
 4537: 		if($transform_name =~ /$TRANSFORM_POSITIVE_PATTERN/i) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4538: 			push @properties, {
 4539: 				name => 'non_negative',
 4540: 				code => "defined(\$result) && looks_like_number(\$result) && \$result >= 0",
 4541: 			};
 4542: 		}
 4543: 	}
 4544: 
 4545: 	# --------------------------------------------------
 4546: 	# Property 2: Specific value output
 4547: 	# --------------------------------------------------
●4548 → 4548 → 4564 4548: 	if(defined($output_spec->{'value'})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4549: 		my $expected = $output_spec->{'value'};
 4550: 
 4551: 		# Numeric refs use == for comparison; scalars use eq
 4552: 		# via perl_quote to produce the correct quoted literal
 4553: 		push @properties, {
 4554: 			name => 'exact_value',
 4555: 			code => ref($expected)
 4556: 				? "\$result == $expected"
 4557: 				: "\$result eq " . perl_quote($expected),
 4558: 		};
 4559: 	}
 4560: 
 4561: 	# --------------------------------------------------
 4562: 	# Property 3: String length constraints
 4563: 	# --------------------------------------------------
●4564 → 4564 → 4603 4564: 	if(_is_string_transform($input_spec, $output_spec)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4565: 		if(defined($output_spec->{'min'})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4566: 			push @properties, {
 4567: 				name => 'min_length',
 4568: 				code => "length(\$result) >= $output_spec->{'min'}",
 4569: 			};
 4570: 		}
 4571: 
 4572: 		if(defined($output_spec->{'max'})) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_4572_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 4573: 			push @properties, {
 4574: 				name => 'max_length',
 4575: 				code => "length(\$result) <= $output_spec->{'max'}",
 4576: 			};
 4577: 		}
 4578: 
 4579: 		if(defined($output_spec->{'matches'})) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_4579_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 4580: 			my $pattern = $output_spec->{'matches'};
 4581: 
 4582: 			# See the matching comment in _schema_to_lectrotest_generator —
 4583: 			# compile first and re-embed via regexp_pattern() rather than
 4584: 			# splicing the raw string into qr/$pattern/, which would let
 4585: 			# an unescaped '/' break out of the delimiter.
 4586: 			my $compiled = ref($pattern) eq 'Regexp' ? $pattern : eval { qr/$pattern/ };
 4587: 			if($@ || !defined($compiled)) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_4587_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 4588: 				carp "Invalid matches pattern '$pattern' for transform '$transform_name': $@";
 4589: 			} else {
 4590: 				my ($pat, $mods) = regexp_pattern($compiled);
 4591: 				my $safe_re = "qr{$pat}" . ($mods // '');
 4592: 				push @properties, {
 4593: 					name => 'pattern_match',
 4594: 					code => "\$result =~ $safe_re",
 4595: 				};
 4596: 			}
 4597: 		}
 4598: 	}
 4599: 
 4600: 	# --------------------------------------------------
 4601: 	# Property 4: Type preservation
 4602: 	# --------------------------------------------------
●4603 → 4603 → 4622 4603: 	if(_same_type($input_spec, $output_spec)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4604: 		my $type = _get_dominant_type($output_spec);
 4605: 
 4606: 		# Only emit a numeric_type check for numeric types —
 4607: 		# string and other types have no equivalent simple check
 4608: 		if($type eq 'number' || $type eq 'integer' || $type eq 'float') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4609: 			push @properties, {
 4610: 				name => 'numeric_type',
 4611: 				code => 'looks_like_number($result)',
 4612: 			};
 4613: 		}
 4614: 	}
 4615: 
 4616: 	# --------------------------------------------------
 4617: 	# Property 5: Definedness
 4618: 	# --------------------------------------------------
 4619: 	# Emit a defined() check for all transforms except those
 4620: 	# whose output type is explicitly 'undef' — those are
 4621: 	# expected to return nothing
●4622 → 4622 → 4629 4622: 	unless(($output_spec->{'type'} // '') eq 'undef') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4623: 		push @properties, {
 4624: 			name => 'defined',
 4625: 			code => 'defined($result)',
 4626: 		};
 4627: 	}
 4628: 
 4629: 	return @properties;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4630: }
 4631: 
 4632: # --------------------------------------------------
 4633: # _process_custom_properties
 4634: #
 4635: # Purpose:    Process the 'properties' array from a
 4636: #             transform definition, resolving each
 4637: #             entry to either a named builtin property
 4638: #             (looked up from _get_builtin_properties)
 4639: #             or a custom property with inline code.
 4640: #
 4641: # Entry:      $properties_spec - arrayref of property
 4642: #                                definitions from the
 4643: #                                schema. Each element
 4644: #                                is either a string
 4645: #                                (builtin name) or a
 4646: #                                hashref with 'name'
 4647: #                                and 'code' fields.
 4648: #             $function        - name of the function
 4649: #                                under test.
 4650: #             $module          - module name, or undef
 4651: #                                for builtins.
 4652: #             $input_spec      - the transform's input
 4653: #                                spec hashref.
 4654: #             $output_spec     - the transform's output
 4655: #                                spec hashref.
 4656: #             $new             - defined if the function
 4657: #                                is an OO method; value
 4658: #                                is not used, only
 4659: #                                presence is checked.
 4660: #
 4661: # Exit:       Returns a list of property hashrefs,
 4662: #             each containing 'name', 'code', and
 4663: #             'description' keys.
 4664: #             Invalid or unrecognised entries are
 4665: #             skipped with a carp warning.
 4666: #
 4667: # Side effects: Carps on unrecognised builtin names,
 4668: #               missing code fields, and invalid
 4669: #               property definition types.
 4670: #
 4671: # Notes:      The sixth argument is $new (the OO
 4672: #             constructor signal), not the full schema
 4673: #             hashref. It is used only to determine
 4674: #             whether to emit OO-style call code for
 4675: #             builtin property templates.
 4676: # --------------------------------------------------
 4677: sub _process_custom_properties {
●4678 → 4683 → 4762 4678: 	my ($properties_spec, $function, $module, $input_spec, $output_spec, $new) = @_;
 4679: 
 4680: 	my @properties;
 4681: 	my $builtin_properties = _get_builtin_properties();
 4682: 
 4683: 	for my $prop_def (@{$properties_spec}) {
 4684: 		my $prop_name;
 4685: 		my $prop_code;
 4686: 		my $prop_desc;
 4687: 
 4688: 		if(!ref($prop_def)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4689: 			# Plain string — look up as a named builtin property
 4690: 			$prop_name = $prop_def;
 4691: 
 4692: 			unless(exists($builtin_properties->{$prop_name})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4693: 				carp "Unknown built-in property '$prop_name', skipping";
 4694: 				next;
 4695: 			}
 4696: 
 4697: 			my $builtin = $builtin_properties->{$prop_name};
 4698: 
 4699: 			# Build the argument list, respecting positional order
 4700: 			my @var_names = sort keys %{$input_spec};
 4701: 			my @args;
 4702: 			if(_has_positions($input_spec)) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_4702_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 4703: 				my @sorted = sort { $input_spec->{$a}{'position'} <=> $input_spec->{$b}{'position'} } @var_names;
 4704: 				@args = map { "\$$_" } @sorted;
 4705: 			} else {
 4706: 				@args = map { "\$$_" } @var_names;
 4707: 			}
 4708: 
 4709: 			# Build the call expression for the builtin template.
 4710: 			# $new here is the raw OO signal from the caller —
 4711: 			# defined means OO mode, undef means functional
 4712: 			my $call_code;
 4713: 			if($module && defined($new)) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_4713_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 4714: 				# OO mode — fresh object per trial
 4715: 				$call_code  = "my \$obj = new_ok('$module');";
 4716: 				$call_code .= "\$obj->$function";
 4717: 			} elsif($module && $module ne $MODULE_BUILTIN) {
 4718: 				# Functional mode with a named module
 4719: 				$call_code = "$module\::$function";
 4720: 			} else {
 4721: 				# Builtin or unqualified function call
 4722: 				$call_code = $function;
 4723: 			}
 4724: 			$call_code .= '(' . join(', ', @args) . ')';
 4725: 
 4726: 			# Instantiate the builtin's code template with the
 4727: 			# call expression and input variable list
 4728: 			$prop_code = $builtin->{'code_template'}->($function, $call_code, \@var_names);
 4729: 			$prop_desc = $builtin->{'description'};
 4730: 
 4731: 		} elsif(ref($prop_def) eq 'HASH') {
 4732: 			# Hashref — custom property with inline Perl code
 4733: 			$prop_name = $prop_def->{'name'} || 'custom_property';
 4734: 			$prop_code = $prop_def->{'code'};
 4735: 			$prop_desc = $prop_def->{'description'} || "Custom property: $prop_name";
 4736: 
 4737: 			unless($prop_code) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4738: 				carp "Custom property '$prop_name' missing 'code' field, skipping";
 4739: 				next;
 4740: 			}
 4741: 
 4742: 			# Sanity-check: code must contain at least a variable
 4743: 			# reference or a word character to be meaningful
 4744: 			unless($prop_code =~ /\$/ || $prop_code =~ /\w+/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4745: 				carp "Custom property '$prop_name' code looks invalid: $prop_code";
 4746: 				next;
 4747: 			}
 4748: 
 4749: 		} else {
 4750: 			# Neither string nor hashref — unrecognised definition type
 4751: 			carp 'Invalid property definition: ', render_fallback($prop_def);
 4752: 			next;
 4753: 		}
 4754: 
 4755: 		push @properties, {
 4756: 			name        => $prop_name,
 4757: 			code        => $prop_code,
 4758: 			description => $prop_desc,
 4759: 		};
 4760: 	}
 4761: 
 4762: 	return @properties;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4763: }
 4764: 
 4765: =head1 NOTES
 4766: 
 4767: C<seed> and C<iterations> really should be within C<config>.
 4768: 
 4769: =head1 SEE ALSO
 4770: 
 4771: =over 4
 4772: 
 4773: =item * L<Test Dashboard|https://nigelhorne.github.io/App-Test-Generator/coverage/>
 4774: 
 4775: =item * L<App::Test::Generator::Template> - Template of the file of tests created by C<App::Test::Generator>
 4776: 
 4777: =item * L<App::Test::Generator::SchemaExtractor> - Create schemas from Perl programs
 4778: 
 4779: =item * L<Params::Validate::Strict>: Schema Definition
 4780: 
 4781: =item * L<Params::Get>: Input validation
 4782: 
 4783: =item * L<Return::Set>: Output validation
 4784: 
 4785: =item * L<Test::LectroTest>
 4786: 
 4787: =item * L<Test::Most>
 4788: 
 4789: =item * L<YAML::XS>
 4790: 
 4791: =back
 4792: 
 4793: =head1 AUTHOR
 4794: 
 4795: Nigel Horne, C<< <njh at nigelhorne.com> >>
 4796: 
 4797: Portions of this module's initial design and documentation were created with the
 4798: assistance of AI.
 4799: 
 4800: =head1 SUPPORT
 4801: 
 4802: This module is provided as-is without any warranty.
 4803: 
 4804: You can find documentation for this module with the perldoc command.
 4805: 
 4806:     perldoc App::Test::Generator
 4807: 
 4808: You can also look for information at:
 4809: 
 4810: =over 4
 4811: 
 4812: =item * MetaCPAN
 4813: 
 4814: L<https://metacpan.org/release/App-Test-Generator>
 4815: 
 4816: =item * GitHub
 4817: 
 4818: L<https://github.com/nigelhorne/App-Test-Generator>
 4819: 
 4820: =item * CPANTS
 4821: 
 4822: L<http://cpants.cpanauthors.org/dist/App-Test-Generator>
 4823: 
 4824: =item * CPAN Testers' Matrix
 4825: 
 4826: L<http://matrix.cpantesters.org/?dist=App-Test-Generator>
 4827: 
 4828: =item * CPAN Testers Dependencies
 4829: 
 4830: L<http://deps.cpantesters.org/?module=App::Test::Generator>
 4831: 
 4832: =back
 4833: 
 4834: =head1 LICENCE AND COPYRIGHT
 4835: 
 4836: Copyright 2025-2026 Nigel Horne.
 4837: 
 4838: Usage is subject to the terms of GPL2.
 4839: If you use it,
 4840: please let me know.
 4841: 
 4842: =cut
 4843: 
 4844: 1;