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

					

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

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

 1651: 				undef $module;
 1652: 			}
 1653: 		}
 1654: 	} elsif($module eq $MODULE_BUILTIN) {
 1655: 		undef $module;
 1656: 	}
 1657: 
●1658 → 1658 → 1665 1658: 	if($module && length($module) && ($module ne 'builtin')) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1659: 		_validate_module($module, $schema_file);
 1660: 	}
 1661: 
 1662: 	# $module/$function are spliced unescaped into generated test
 1663: 	# source below (use_ok, new_ok, ->$function, $module::$function)
 1664: 	# — reject anything that isn't identifier-shaped before that happens.
●1665 → 1678 → 1699 1665: 	_assert_identifier($module, 'module', package => 1) if defined($module) && length($module);
 1666: 
 1667: 	# sensible defaults
 1668: 	$function ||= 'run';
 1669: 	# package => 1: fully-qualified sub names (e.g. DB::DB, a debugger
 1670: 	# hook installed into the DB:: package regardless of its source
 1671: 	# package) are legitimate function names, not just bare identifiers
 1672: 	_assert_identifier($function, 'function', package => 1);
 1673: 	$iterations ||= DEFAULT_ITERATIONS;		 # default fuzz runs if not specified
 1674: 	$seed = undef if defined $seed && $seed eq '';	# treat empty as undef
 1675: 
 1676: 	# --- YAML corpus support (yaml_cases is filename string) ---
 1677: 	my %yaml_corpus_data;
 1678: 	if (defined $yaml_cases) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1679: 		croak("$yaml_cases: $!") if(!-f $yaml_cases);
 1680: 
 1681: 		my $yaml_data = LoadFile(Encode::decode('utf8', $yaml_cases));
 1682: 		if ($yaml_data && ref($yaml_data) eq 'HASH') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1683: 			# Validate that the corpus inputs are arrayrefs
 1684: 			# e.g: "FooBar": 	["foo_bar"]
 1685: 			# Skip only invalid entries:
 1686: 			for my $expected (keys %{$yaml_data}) {
 1687: 				my $outputs = $yaml_data->{$expected};
 1688: 				unless($outputs && (ref $outputs eq 'ARRAY')) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1689: 					carp("$yaml_cases: $expected does not point to an array ref, ignoring");
 1690: 					next;
 1691: 				}
 1692: 				$yaml_corpus_data{$expected} = $outputs;
 1693: 			}
 1694: 		}
 1695: 	}
 1696: 
 1697: 	# Merge Perl %cases and YAML corpus safely
 1698: 	# my %all_cases = (%cases, %yaml_corpus_data);
●1699 → 1700 → 1706 1699: 	my %all_cases = (%yaml_corpus_data, %cases);
 1700: 	for my $k (keys %yaml_corpus_data) {
 1701: 		if (exists $cases{$k} && ref($cases{$k}) eq 'ARRAY' && ref($yaml_corpus_data{$k}) eq 'ARRAY') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1702: 			$all_cases{$k} = [ @{$yaml_corpus_data{$k}}, @{$cases{$k}} ];
 1703: 		}
 1704: 	}
 1705: 
●1706 → 1706 → 1716 1706: 	if(my $hints = delete $schema->{_yamltest_hints}) {

					

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

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

 1707: 		if(my $boundaries = $hints->{boundary_values}) {

					

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

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

 1708: 			push @edge_case_array, @{$boundaries};
 1709: 		}
 1710: 		if(my $invalid = $hints->{invalid}) {

					

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

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

 1711: 			carp('TODO: handle yamltest_hints->invalid');
 1712: 		}
 1713: 	}
 1714: 
 1715: 	# If the schema says the type is numeric, normalize
●1716 → 1716 → 1726 1716: 	if ($schema->{type} && $schema->{type} =~ /^(integer|number|float)$/) {

					

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

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

 1717: 		for (@edge_case_array) {
 1718: 			next unless defined $_;
 1719: 			$_ += 0 if Scalar::Util::looks_like_number($_);
 1720: 		}
 1721: 	}
 1722: 
 1723: 	# Load relationships from the schema if present and well-formed.
 1724: 	# SchemaExtractor may set this to undef or an empty arrayref when
 1725: 	# no relationships were detected, so guard both existence and type.
●1726 → 1727 → 1735 1726: 	my @relationships;
 1727: 	if(exists($schema->{relationships}) && ref($schema->{relationships}) eq 'ARRAY') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1728: 		@relationships = @{$schema->{relationships}};
 1729: 	}
 1730: 
 1731: 	# Serialise the relationships array from the schema into Perl source
 1732: 	# code for embedding in the generated test file. Each relationship
 1733: 	# type is rendered as a hashref in the @relationships array.
 1734: 
●1735 → 1738 → 1787 1735: 	my $relationships_code = '';
 1736: 
 1737: 	# Walk each relationship in the order SchemaExtractor produced them
 1738: 	for my $rel (@relationships) {
 1739: 		my $type = $rel->{type} // '';
 1740: 
 1741: 		# Mutually exclusive: both params being set should cause the method to die
 1742: 		if($type eq 'mutually_exclusive') {

					

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

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

 1743: 			$relationships_code .= "{ type => 'mutually_exclusive', params => [" .
 1744: 				join(', ', map { perl_quote($_) } @{$rel->{params}}) .
 1745: 				"] },\n";
 1746: 
 1747: 		# Required group: at least one of the params must be present
 1748: 		} elsif($type eq 'required_group') {
 1749: 			$relationships_code .= "{ type => 'required_group', params => [" .
 1750: 				join(', ', map { perl_quote($_) } @{$rel->{params}}) .
 1751: 				"], logic => " . perl_quote($rel->{logic} // 'or') . " },\n";
 1752: 
 1753: 		# Conditional requirement: if one param is set, another becomes mandatory
 1754: 		} elsif($type eq 'conditional_requirement') {
 1755: 			$relationships_code .= "{ type => 'conditional_requirement', if => " .
 1756: 				perl_quote($rel->{'if'}) . ", then_required => " .
 1757: 				perl_quote($rel->{then_required}) . " },\n";
 1758: 
 1759: 		# Dependency: one param requires another to also be present
 1760: 		} elsif($type eq 'dependency') {
 1761: 			$relationships_code .= "{ type => 'dependency', param => " .
 1762: 				perl_quote($rel->{param}) . ", requires => " .
 1763: 				perl_quote($rel->{requires}) . " },\n";
 1764: 
 1765: 		# Value constraint: one param being set forces another to a specific value
 1766: 		} elsif($type eq 'value_constraint') {
 1767: 			$relationships_code .= "{ type => 'value_constraint', if => " .
 1768: 				perl_quote($rel->{'if'}) . ", then => " .
 1769: 				perl_quote($rel->{then}) . ", operator => " .
 1770: 				perl_quote($rel->{operator}) . ", value => " .
 1771: 				perl_quote($rel->{value}) . " },\n";
 1772: 
 1773: 		# Value conditional: one param equalling a specific value requires another param
 1774: 		} elsif($type eq 'value_conditional') {
 1775: 			$relationships_code .= "{ type => 'value_conditional', if => " .
 1776: 				perl_quote($rel->{'if'}) . ", equals => " .
 1777: 				perl_quote($rel->{equals}) . ", then_required => " .
 1778: 				perl_quote($rel->{then_required}) . " },\n";
 1779: 
 1780: 		# Unknown type — warn and skip rather than emitting broken code
 1781: 		} else {
 1782: 			carp "Unknown relationship type '$type', skipping";
 1783: 		}
 1784: 	}
 1785: 
 1786: 	# Dedup the edge cases
●1787 → 1812 → 1817 1787: 	my %seen;
 1788: 	@edge_case_array = grep {
 1789: 		my $key = defined($_) ? (Scalar::Util::looks_like_number($_) ? "N:$_" : "S:$_") : 'U';
 1790: 		!$seen{$key}++;
 1791: 	} @edge_case_array;
 1792: 
 1793: 	# Sort the edge cases to keep it consistent across runs
 1794: 	@edge_case_array = sort {
 1795: 		return -1 if !defined $a;

					

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

				
BOOL_NEGATE_1795_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_1795_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' );

								
							
 1796: 		return 1 if !defined $b;

					

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

				
BOOL_NEGATE_1796_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_1796_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' );

								
							
 1797: 
 1798: 		my $na = Scalar::Util::looks_like_number($a);
 1799: 		my $nb = Scalar::Util::looks_like_number($b);
 1800: 
 1801: 		return $a <=> $b if $na && $nb;

					

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

				
BOOL_NEGATE_1801_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_1801_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' );

								
							
 1802: 		return -1 if $na;

					

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

				
BOOL_NEGATE_1802_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_1802_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' );

								
							
 1803: 		return 1 if $nb;

					

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

				
BOOL_NEGATE_1803_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_1803_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' );

								
							
 1804: 		return $a cmp $b;

					

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

				
BOOL_NEGATE_1804_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_1804_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' );

								
							
 1805: 	} @edge_case_array;
 1806: 
 1807: 	# render edge case maps for inclusion in the .t
 1808: 	my $edge_cases_code = render_arrayref_map(\%edge_cases);
 1809: 	my $type_edge_cases_code = render_arrayref_map(\%type_edge_cases);
 1810: 
 1811: 	my $edge_case_array_code = '';
 1812: 	if(scalar(@edge_case_array)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1813: 		$edge_case_array_code = join(', ', map { q_wrap($_) } @edge_case_array);
 1814: 	}
 1815: 
 1816: 	# Render configuration - all the values are integers for now, if that changes, wrap the $config{$key} in single quotes
●1817 → 1818 → 1834 1817: 	my $config_code = '';
 1818: 	foreach my $key (sort keys %config) {
 1819: 		# Skip nested structures like 'properties' - they're used during
 1820: 		# generation but don't need to be in the generated test
 1821: 		if(ref($config{$key}) eq 'HASH') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1822: 			next;
 1823: 		}
 1824: 		if((!defined($config{$key})) || !$config{$key}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1825: 			# YAML will strip the word 'false'
 1826: 			# e.g. in 'test_undef: false'
 1827: 			$config_code .= "'$key' => 0,\n";
 1828: 		} else {
 1829: 			$config_code .= "'$key' => $config{$key},\n";
 1830: 		}
 1831: 	}
 1832: 
 1833: 	# Render input/output
●1834 → 1835 → 1844 1834: 	my $input_code = '';
 1835: 	if(((scalar keys %input) == 1) && exists($input{'type'}) && !ref($input{'type'})) {

					

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

				
NUM_BOUNDARY_1835_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' );

								
							
 1836: 		# %input = ( type => 'string' );
 1837: 		foreach my $key (sort keys %input) {
 1838: 			$input_code .= "'$key' => '$input{$key}',\n";
 1839: 		}
 1840: 	} else {
 1841: 		# %input = ( str => { type => 'string' } );
 1842: 		$input_code = render_hash(\%input);
 1843: 	}
●1844 → 1844 → 1861 1844: 	if(defined(my $re = $output{'matches'})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1845: 		if(ref($re) ne 'Regexp') {

					

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

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

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

					

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

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

 1850: 				carp("Invalid matches pattern '$re': $@");
 1851: 			} else {
 1852: 				$output{'matches'} = $compiled;
 1853: 			}
 1854: 		}
 1855: 	}
 1856: 
 1857: 	# Compile nomatch pattern to a Regexp object so it renders
 1858: 	# as qr{} in the generated test rather than a raw string.
 1859: 	# Without this, patterns containing [ or other regex
 1860: 	# metacharacters cause compilation failures in validators
●1861 → 1861 → 1874 1861: 	if(defined(my $re = $output{'nomatch'})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1862: 		if(ref($re) ne 'Regexp') {

					

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

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

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

					

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

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

 1867: 				carp("Invalid nomatch pattern '$re': $@");
 1868: 			} else {
 1869: 				$output{'nomatch'} = $compiled;
 1870: 			}
 1871: 		}
 1872: 	}
 1873: 
●1874 → 1878 → 1896 1874: 	my $output_code = render_args_hash(\%output);
 1875: 	my $new_code = ($new && (ref $new eq 'HASH')) ? render_args_hash($new) : '';
 1876: 
 1877: 	my $transforms_code;
 1878: 	if(keys %transforms) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1879: 		foreach my $transform(keys %transforms) {
 1880: 			my $properties = render_fallback($transforms{$transform}->{'properties'});
 1881: 
 1882: 			if($transforms_code) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1883: 				$transforms_code .= "},\n";
 1884: 			}
 1885: 			$transforms_code .= "$transform => {\n" .
 1886: 				"\t'input' => { " .
 1887: 				render_args_hash($transforms{$transform}->{'input'}) .
 1888: 				"\t}, 'output' => { " .
 1889: 				render_args_hash($transforms{$transform}->{'output'}) .
 1890: 				"\t}, 'properties' => $properties\n" .
 1891: 				"\t,\n";
 1892: 		}
 1893: 		$transforms_code .= "}\n";
 1894: 	}
 1895: 
●1896 → 1899 → 1916 1896: 	my $transform_properties_code = '';
 1897: 	my $use_properties = 0;
 1898: 
 1899: 	if (keys %transforms && ($config{properties}{enable} // 0)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1900: 		$use_properties = 1;
 1901: 
 1902: 		# Generate property-based tests for transforms
 1903: 		my $properties = _generate_transform_properties(
 1904: 			\%transforms,
 1905: 			$function,
 1906: 			$module,
 1907: 			\%input,
 1908: 			\%config,
 1909: 			$new
 1910: 		);
 1911: 
 1912: 		# Convert to code for template
 1913: 		$transform_properties_code = _render_properties($properties);
 1914: 	}
 1915: 
●1916 → 1916 → 1935 1916: 	if(keys %accessor) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1917: 		# Sanity test
 1918: 		my $property = $accessor{property};
 1919: 		my $type = $accessor{type};
 1920: 
 1921: 		if(!defined($new)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1922: 			croak("BUG: $property: accessor $type can only work on an object, incorrectly tagged as $type");
 1923: 		}
 1924: 		if($type eq 'getset') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1925: 			if(scalar(keys %input) != 1) {

					

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

				
NUM_BOUNDARY_1925_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_1925_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 1926: 				croak("BUG: $property: getset must take one input argument, incorrectly tagged as getset");
 1927: 			}
 1928: 			if(scalar(keys %output) == 0) {

					

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

				
NUM_BOUNDARY_1928_28_!=: 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_1928_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 1929: 				croak("BUG: $property: getset must give one output, incorrectly tagged as getset");
 1930: 			}
 1931: 		}
 1932: 	}
 1933: 
 1934: 	# Setup / call code (always load module)
●1935 → 1939 → 2007 1935: 	my $setup_code = ($module) ? "BEGIN { use_ok('$module') }" : '';
 1936: 	my $call_code;	# Code to call the function being test when used with named arguments
 1937: 	my $position_code;	# Code to call the function being test when used with position arguments
 1938: 	my $has_positions = _has_positions(\%input);
 1939: 	if(defined($new) && defined($module)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1940: 		# keep use_ok regardless (user found earlier issue)
 1941: 		if($new_code eq '') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1942: 			$new_code = "new_ok('$module')";
 1943: 		} else {
 1944: 			$new_code = "new_ok('$module' => [ { $new_code } ] )";
 1945: 		}
 1946: 		$setup_code .= "\nmy \$obj = $new_code;";
 1947: 		if($has_positions) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1948: 			$position_code = "\$result = (scalar(\@alist) == 1) ? \$obj->$function(\$alist[0]) : (scalar(\@alist) == 0) ? \$obj->$function() : \$obj->$function(\@alist);";
 1949: 			if(defined($accessor{type})) {

					

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

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

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

					

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

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

 1951: 					$position_code .= "my \$prev_value = \$obj->{$accessor{property}};";
 1952: 				} elsif($accessor{type} eq 'getset') {
 1953: 					$position_code .= 'if(scalar(@alist) == 1) { ';
 1954: 					$position_code .= "cmp_ok(\$result, 'eq', \$alist[0], 'getset function returns what was put in'); ok(\$obj->$function() eq \$result, 'test getset accessor');";
 1955: 					$position_code .= '}';
 1956: 				}
 1957: 				if(($accessor{type} eq 'getset') || ($accessor{type} eq 'getter')) {

					

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

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

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

					

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

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

 1962: 						$position_code .= "if(defined(\$prev_value)) { cmp_ok(\$result, 'eq', \$prev_value, 'getter does not change value'); } ";
 1963: 					}
 1964: 					$position_code .= '}';
 1965: 				}
 1966: 				if($output{'_returns_self'}) {

					

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

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

 1967: 					croak("$accessor{type} for $accessor{property} cannot return \$self");
 1968: 				}
 1969: 			}
 1970: 		} else {
 1971: 			$call_code = "\$result = \$obj->$function(\$input);";
 1972: 			if($output{'_returns_self'}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1973: 				$call_code .= "ok(defined(\$result)); ok(\$result eq \$obj, '$function returns self')";
 1974: 			} elsif(defined($accessor{type}) && ($accessor{type} eq 'getset')) {
 1975: 				$call_code .= "ok(\$obj->$function() eq \$result, 'test getset accessor');"
 1976: 			}
 1977: 			if(scalar(keys %input) == 0) {

					

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

				
NUM_BOUNDARY_1977_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_1977_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 1978: 				if(defined($accessor{type}) && ($accessor{type} eq 'getter')) {

					

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

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

 1979: 					$call_code .= "cmp_ok(\$result, 'eq', \$obj->{$accessor{property}}, 'getter function returns correct item') if(defined(\$result));";
 1980: 				}
 1981: 			}
 1982: 		}
 1983: 	} elsif(defined($module) && length($module)) {
 1984: 		if($function eq 'new') {

					

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

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

 1985: 			if($has_positions) {

					

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

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

 1986: 				$position_code = "\$result = (scalar(\@alist) == 1) ? ${module}\->$function(\$alist[0]) : (scalar(\@alist) == 0) ? ${module}\->$function() : ${module}\->$function(\@alist);";
 1987: 			} else {
 1988: 				$call_code = "\$result = ${module}\->$function(\$input);";
 1989: 			}
 1990: 		} else {
 1991: 			if($has_positions) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1992: 				$position_code = "\$result = (scalar(\@alist) == 1) ? ${module}::$function(\$alist[0]) : (scalar(\@alist) == 0) ? ${module}::$function() : ${module}::$function(\@alist);";
 1993: 			} else {
 1994: 				$call_code = "\$result = ${module}::$function(\$input);";
 1995: 			}
 1996: 		}
 1997: 	} else {
 1998: 		if($has_positions) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 1999: 			$position_code = "\$result = $function(\@alist);";
 2000: 		} else {
 2001: 			$call_code = "\$result = $function(\$input);";
 2002: 		}
 2003: 	}
 2004: 
 2005: 	# List-context capture: $result = func() in scalar context returns a count, not the list.
 2006: 	# When the schema says output type is 'array', capture into @_r then take a ref.
●2007 → 2007 → 2017 2007: 	if(($output{type} // '') eq 'array') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2008: 		if(defined($call_code)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2009: 			$call_code =~ s/^\$result = (.*?);/my \@_r = ($1); \$result = \\\@_r;/s;
 2010: 		}
 2011: 		if(defined($position_code)) {

					

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

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

 2012: 			$position_code =~ s/^\$result = (.*?);/my \@_r = ($1); \$result = \\\@_r;/s;
 2013: 		}
 2014: 	}
 2015: 
 2016: 	# Build static corpus code
●2017 → 2018 → 2117 2017: 	my $corpus_code = '';
 2018: 	if (%all_cases) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2019: 		$corpus_code = "\n# --- Static Corpus Tests ---\n" .
 2020: 			"diag('Running " . scalar(keys %all_cases) . " corpus tests');\n";
 2021: 
 2022: 		for my $expected (sort keys %all_cases) {
 2023: 			my $inputs = $all_cases{$expected};
 2024: 			next unless($inputs);
 2025: 
 2026: 			my $expected_str = perl_quote($expected);
 2027: 			my $status = ((ref($inputs) eq 'HASH') && $inputs->{'_STATUS'}) // 'OK';
 2028: 			if($expected_str eq "'_STATUS:DIES'") {

					

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

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

 2029: 				$status = 'DIES';
 2030: 			} elsif($expected_str eq "'_STATUS:WARNS'") {
 2031: 				$status = 'WARNS';
 2032: 			}
 2033: 
 2034: 			if(ref($inputs) eq 'HASH') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2035: 				$inputs = $inputs->{'input'};
 2036: 			}
 2037: 			my $input_str;
 2038: 			if(ref($inputs) eq 'ARRAY') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2039: 				$input_str = join(', ', map { perl_quote($_) } @{$inputs});
 2040: 			} elsif(ref($inputs) eq 'HASH') {
 2041: 				$input_str = render_fallback($inputs);
 2042: 
 2043: 				# YAML can't express Perl's undef, so a corpus value of
 2044: 				# the sentinel string 'undef' means "this param is
 2045: 				# undef" -- convert the quoted sentinel back to the
 2046: 				# bareword so the generated test passes real undef
 2047: 				$input_str =~ s/=> 'undef'/=> undef/gms;
 2048: 			} else {
 2049: 				$input_str = $inputs;
 2050: 			}
 2051: 			if(($input_str eq 'undef') && (!$config{'test_undef'})) {

					

					
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: 				carp('corpus case set to undef, yet test_undef is not set in config');
 2053: 			}
 2054: 			if($new) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2055: 				if($status eq 'DIES') {

					

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

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

 2056: 					$corpus_code .= "dies_ok { \$obj->$function($input_str) } " .
 2057: 							"'$function(" . join(', ', map { $_ // '' } @$inputs ) . ") dies';\n";
 2058: 				} elsif($status eq 'WARNS') {
 2059: 					$corpus_code .= "warnings_exist { \$obj->$function($input_str) } qr/./, " .
 2060: 							"'$function(" . join(', ', map { $_ // '' } @$inputs ) . ") warns';\n";
 2061: 				} else {
 2062: 					my $desc = sprintf("$function(%s) returns %s",
 2063: 						perl_quote(join(', ', map { $_ // '' } @$inputs )),
 2064: 						$expected_str
 2065: 					);
 2066: 					if(($output{'type'} // '') eq 'boolean') {

					

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

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

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

					

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

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

 2068: 							$corpus_code .= "ok(\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
 2069: 						} elsif($expected_str eq '0') {
 2070: 							$corpus_code .= "ok(!\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
 2071: 						} else {
 2072: 							croak("Boolean is expected to return $expected_str");
 2073: 						}
 2074: 					} else {
 2075: 						$corpus_code .= "is(\$obj->$function($input_str), $expected_str, " . q_wrap($desc) . ");\n";
 2076: 					}
 2077: 				}
 2078: 			} else {
 2079: 				if($status eq 'DIES') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2080: 					if($module) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2081: 						$corpus_code .= "dies_ok { $module\::$function($input_str) } " .
 2082: 							"'Corpus $expected dies';\n";
 2083: 					} else {
 2084: 						$corpus_code .= "dies_ok { $function($input_str) } " .
 2085: 							"'Corpus $expected dies';\n";
 2086: 					}
 2087: 				} elsif($status eq 'WARNS') {
 2088: 					if($module) {

					

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

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

 2089: 						$corpus_code .= "warnings_exist { $module\::$function($input_str) } qr/./, " .
 2090: 							"'Corpus $expected warns';\n";
 2091: 					} else {
 2092: 						$corpus_code .= "warnings_exist { $function($input_str) } qr/./, " .
 2093: 							"'Corpus $expected warns';\n";
 2094: 					}
 2095: 				} else {
 2096: 					my $desc = sprintf("$function(%s) returns %s",
 2097: 						perl_quote((ref $inputs eq 'ARRAY') ? (join(', ', map { $_ // '' } @{$inputs})) : $inputs),
 2098: 						$expected_str
 2099: 					);
 2100: 					if(($output{'type'} // '') eq 'boolean') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2101: 						if($expected_str eq '1') {

					

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

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

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

					

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

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

 2823: 		print STDERR "Found module '$module' at: $mod_info->{'file'}\n",
 2824: 			'  Version: ', ($mod_info->{'version'} || 'unknown'), "\n";
 2825: 	}
 2826: 
 2827: 	# Optional load validation — disabled by default because
 2828: 	# loading a module can have side effects (e.g. BEGIN blocks,
 2829: 	# database connections, file I/O) that are undesirable
 2830: 	# during generation
●2831 → 2831 → 2848 2831: 	if($ENV{$ENV_VALIDATE_LOAD}) {

					

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

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

 2832: 		my $loaded = can_load(modules => { $module => undef }, verbose => 0);
 2833: 
 2834: 		if(!$loaded) {

					

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

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

 2835: 			my $err = $Module::Load::Conditional::ERROR || 'unknown error';
 2836: 			carp(
 2837: 				"Module '$module' found but failed to load: $err\n" .
 2838: 				'  This might indicate a broken installation or missing dependencies.'
 2839: 			);
 2840: 			return 0;

					

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

				
BOOL_NEGATE_2840_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_2840_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' );

								
							
 2841: 		}
 2842: 
 2843: 		if($verbose) {

					

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

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

 2844: 			print STDERR "Successfully loaded module '$module'\n";
 2845: 		}
 2846: 	}
 2847: 
 2848: 	return 1;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 2849: }
 2850: 
 2851: =head2 render_fallback
 2852: 
 2853: Render any Perl value into a compact Perl source-code string using
 2854: L<Data::Dumper>. Used as a catch-all when no more specific renderer
 2855: applies.
 2856: 
 2857:     my $code = render_fallback({ key => 'value' });
 2858:     # returns: "{'key' => 'value'}"
 2859: 
 2860: =head3 Arguments
 2861: 
 2862: =over 4
 2863: 
 2864: =item * C<$v>
 2865: 
 2866: Any Perl value, including undef, scalars, refs, and blessed objects.
 2867: 
 2868: =back
 2869: 
 2870: =head3 Returns
 2871: 
 2872: A string of Perl source code that reproduces the value when evaluated.
 2873: Returns the string C<'undef'> when C<$v> is undef.
 2874: 
 2875: =head3 Side effects
 2876: 
 2877: Temporarily sets C<$Data::Dumper::Terse> and C<$Data::Dumper::Indent>
 2878: to produce compact single-line output. Both are restored on return via
 2879: C<local>.
 2880: 
 2881: =head3 Notes
 2882: 
 2883: The output is always a single line with no trailing newline. Suitable
 2884: for embedding in generated test code where readability is secondary to
 2885: correctness.
 2886: 
 2887: =head3 API specification
 2888: 
 2889: =head4 input
 2890: 
 2891:     { v => { type => 'any', optional => 1 } }
 2892: 
 2893: =head4 output
 2894: 
 2895:     { type => 'string' }
 2896: 
 2897: =cut
 2898: 
 2899: sub render_fallback {
 2900: 	my $v = $_[0];
 2901: 
 2902: 	# Handle undef explicitly rather than letting Dumper produce
 2903: 	# 'undef' without the localised settings applied
 2904: 	return 'undef' unless defined $v;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 2905: 
 2906: 	# Use Terse+Indent=0 to produce compact single-line output
 2907: 	# suitable for embedding in generated test code
 2908: 	local $Data::Dumper::Terse  = 1;
 2909: 	local $Data::Dumper::Indent = 0;
 2910: 
 2911: 	my $s = Dumper($v);
 2912: 
 2913: 	# Remove trailing newline that Dumper always appends
 2914: 	chomp $s;
 2915: 	return $s;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 2916: }
 2917: 
 2918: =head2 render_hash
 2919: 
 2920: Render a two-level hashref (parameter name => spec hashref) into Perl
 2921: source code suitable for embedding in a generated test file as the
 2922: input specification passed to L<Params::Validate::Strict>.
 2923: 
 2924:     my $code = render_hash(\%input);
 2925: 
 2926: =head3 Arguments
 2927: 
 2928: =over 4
 2929: 
 2930: =item * C<$href>
 2931: 
 2932: A hashref whose values are themselves hashrefs containing field
 2933: specifications. A scalar value that is a recognised type string (see
 2934: C<_valid_type>) is expanded to C<{ type =E<gt> $value }>. Any other
 2935: non-hashref value is skipped with a warning.
 2936: 
 2937: =back
 2938: 
 2939: =head3 Returns
 2940: 
 2941: A string of comma-separated Perl source-code lines, one per key, of
 2942: the form:
 2943: 
 2944:     'key' => { subkey => value, ... }
 2945: 
 2946: Returns an empty string if C<$href> is undef, empty, or not a hashref.
 2947: 
 2948: =head3 Side effects
 2949: 
 2950: None. Does not modify C<$href>.
 2951: 
 2952: =head3 Notes
 2953: 
 2954: The C<matches> and C<nomatch> sub-keys are treated specially — their
 2955: values are compiled to C<Regexp> objects via C<eval { qr/.../ }> and
 2956: then rendered using C<perl_quote> so they appear as C<qr{...}> in the
 2957: generated test. This prevents unmatched bracket characters in the
 2958: pattern from causing compilation failures.
 2959: 
 2960: Other sub-keys are rendered via C<perl_quote>.
 2961: 
 2962: =head3 API specification
 2963: 
 2964: =head4 input
 2965: 
 2966:     { href => { type => 'hashref', optional => 1 } }
 2967: 
 2968: =head4 output
 2969: 
 2970:     { type => 'string' }
 2971: 
 2972: =cut
 2973: 
 2974: sub render_hash {
●2975 → 2983 → 3041 2975: 	my $href = $_[0];
 2976: 
 2977: 	# Return empty string for absent or non-hash input — callers
 2978: 	# treat '' as "no input specification" in the generated test
 2979: 	return '' unless $href && ref($href) eq 'HASH';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 2980: 
 2981: 	my @lines;
 2982: 
 2983: 	for my $k (sort keys %{$href}) {
 2984: 		my $def = $href->{$k};
 2985: 
 2986: 		# Handle scalar shorthand — 'arg1: string' is equivalent to
 2987: 		# 'arg1: { type: string }' and is explicitly supported by the
 2988: 		# validation layer in _validate_input_params
 2989: 		unless(defined($def) && ref($def) eq 'HASH') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2990: 			if(defined($def) && !ref($def) && _valid_type($def)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 2991: 				# Expand scalar type shorthand to a full spec hashref
 2992: 				$def = { type => $def };
 2993: 			} else {
 2994: 				carp "render_hash: skipping key '$k' — value is not a hashref or recognised type string";
 2995: 				next;
 2996: 			}
 2997: 		}
 2998: 
 2999: 		my @pairs;
 3000: 
 3001: 		for my $subk (sort keys %{$def}) {
 3002: 			# Skip undef sub-values — they contribute nothing to the spec
 3003: 			next unless defined $def->{$subk};
 3004: 
 3005: 			# Validate that reference types are ones we can render —
 3006: 			# nested hashrefs are not yet supported
 3007: 			if(ref($def->{$subk})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 3008: 				unless((ref($def->{$subk}) eq 'ARRAY') ||

					

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

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

 3009: 				       (ref($def->{$subk}) eq 'Regexp')) {
 3010: 					croak(
 3011: 						__PACKAGE__,
 3012: 						": $subk is a nested element, not yet supported (",
 3013: 						ref($def->{$subk}), ')'
 3014: 					);
 3015: 				}
 3016: 			}
 3017: 
 3018: 			# matches and nomatch values must be Regexp objects in the
 3019: 			# generated test — compile raw strings safely via eval so
 3020: 			# patterns containing [ or \ don't cause compile failures
 3021: 			if(($subk eq $KEY_MATCHES) || ($subk eq $KEY_NOMATCH)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 3022: 				my $re = ref($def->{$subk}) eq 'Regexp'
 3023: 					? $def->{$subk}
 3024: 					: eval { qr/$def->{$subk}/ };
 3025: 				if($@ || !defined($re)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 3026: 					carp "render_hash: invalid $subk pattern '$def->{$subk}': $@";
 3027: 					next;
 3028: 				}
 3029: 				push @pairs, "$subk => " . perl_quote($re);
 3030: 			} else {
 3031: 				# All other sub-keys are rendered via perl_quote which
 3032: 				# handles scalars, arrayrefs, and Regexp objects correctly
 3033: 				push @pairs, "$subk => " . perl_quote($def->{$subk});
 3034: 			}
 3035: 		}
 3036: 
 3037: 		# Use "\t" rather than a literal tab for clarity and grep-ability
 3038: 		push @lines, "\t" . perl_quote($k) . ' => { ' . join(', ', @pairs) . ' }';
 3039: 	}
 3040: 
 3041: 	return join(",\n", @lines);
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3042: }
 3043: 
 3044: =head2 render_args_hash
 3045: 
 3046: Render a flat hashref into a Perl source-code argument list of the
 3047: form C<'key' => value, ...>, suitable for embedding in a function call
 3048: in a generated test file.
 3049: 
 3050:     my $code = render_args_hash({ type => 'string', min => 1 });
 3051:     # returns: "'min' => 1, 'type' => 'string'"
 3052: 
 3053: =head3 Arguments
 3054: 
 3055: =over 4
 3056: 
 3057: =item * C<$href>
 3058: 
 3059: A flat hashref of key-value pairs. Values may be scalars, arrayrefs,
 3060: or Regexp objects — all are handled by C<perl_quote>.
 3061: 
 3062: =back
 3063: 
 3064: =head3 Returns
 3065: 
 3066: A comma-separated string of C<key => value> pairs sorted by key.
 3067: Returns an empty string if C<$href> is undef, empty, or not a hashref.
 3068: 
 3069: =head3 Notes
 3070: 
 3071: Keys and values are both rendered via C<perl_quote>. In particular,
 3072: C<Regexp> values are rendered as C<qr{...}> which is correct for
 3073: L<Params::Validate::Strict> and L<Return::Set> schema arguments in
 3074: the generated test.
 3075: 
 3076: =head3 API specification
 3077: 
 3078: =head4 input
 3079: 
 3080:     { href => { type => 'hashref', optional => 1 } }
 3081: 
 3082: =head4 output
 3083: 
 3084:     { type => 'string' }
 3085: 
 3086: =cut
 3087: 
 3088: sub render_args_hash {
 3089: 	my $href = $_[0];
 3090: 
 3091: 	# Return empty string for absent or non-hash input
 3092: 	return '' unless $href && ref($href) eq 'HASH';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3093: 
 3094: 	# Sort keys for deterministic output across runs — important for
 3095: 	# generated test files that are committed to version control
 3096: 	my @pairs = map {
 3097: 		perl_quote($_) . ' => ' . perl_quote($href->{$_})
 3098: 	} sort keys %{$href};
 3099: 
 3100: 	return join(', ', @pairs);
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3101: }
 3102: 
 3103: =head2 render_arrayref_map
 3104: 
 3105: Render a hashref whose values are arrayrefs into a Perl source-code
 3106: fragment suitable for use as a hash literal in a generated test file.
 3107: 
 3108:     my $code = render_arrayref_map({ name => ['', 'a' x 100] });
 3109: 
 3110: =head3 Arguments
 3111: 
 3112: =over 4
 3113: 
 3114: =item * C<$href>
 3115: 
 3116: A hashref whose values are arrayrefs. Keys whose values are not
 3117: arrayrefs are silently skipped.
 3118: 
 3119: =back
 3120: 
 3121: =head3 Returns
 3122: 
 3123: A comma-separated string of C<'key' => [ val, ... ]> entries, one per
 3124: qualifying key, sorted alphabetically. Returns the string C<'()'> if
 3125: C<$href> is undef, empty, or not a hashref — this produces an empty
 3126: hash assignment in the generated test rather than a syntax error.
 3127: 
 3128: =head3 Notes
 3129: 
 3130: Array element values are rendered via C<perl_quote> which handles
 3131: scalars, arrayrefs, and Regexp objects. Non-arrayref values are
 3132: skipped without warning — this is intentional since callers may pass
 3133: mixed-value hashes and only want the arrayref entries rendered.
 3134: 
 3135: =head3 API specification
 3136: 
 3137: =head4 input
 3138: 
 3139:     { href => { type => 'hashref', optional => 1 } }
 3140: 
 3141: =head4 output
 3142: 
 3143:     { type => 'string' }
 3144: 
 3145: =cut
 3146: 
 3147: sub render_arrayref_map {
●3148 → 3156 → 3170 3148: 	my $href = $_[0];
 3149: 
 3150: 	# Return '()' rather than '' so callers get a valid empty hash
 3151: 	# literal rather than a syntax error in the generated test
 3152: 	return '()' unless $href && ref($href) eq 'HASH';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3153: 
 3154: 	my @entries;
 3155: 
 3156: 	for my $k (sort keys %{$href}) {
 3157: 		my $aref = $href->{$k};
 3158: 
 3159: 		# Skip non-arrayref values — mixed hashes are allowed by callers
 3160: 		next unless ref($aref) eq 'ARRAY';
 3161: 
 3162: 		# Render each array element via perl_quote so strings are
 3163: 		# properly quoted and numbers are left unquoted
 3164: 		my $vals = join(', ', map { perl_quote($_) } @{$aref});
 3165: 
 3166: 		# Use "\t" rather than a literal tab for clarity
 3167: 		push @entries, "\t" . perl_quote($k) . " => [ $vals ]";
 3168: 	}
 3169: 
 3170: 	return join(",\n", @entries);
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3171: }
 3172: 
 3173: # --------------------------------------------------
 3174: # _has_positions
 3175: #
 3176: # Purpose:    Determine whether any field in an input
 3177: #             spec hashref declares a positional argument
 3178: #             via the 'position' key.
 3179: #
 3180: # Entry:      $input_spec - the input section of a parsed
 3181: #             schema, expected to be a hashref whose values
 3182: #             are themselves hashrefs containing field specs.
 3183: #             May be undef or a non-hash ref.
 3184: #
 3185: # Exit:       Returns 1 if any field has a defined
 3186: #             'position' key, 0 otherwise.
 3187: #
 3188: # Notes:      Returns 0 immediately for undef or non-hash
 3189: #             input rather than throwing — callers use the
 3190: #             return value as a boolean and do not expect
 3191: #             exceptions from this function.
 3192: # --------------------------------------------------
 3193: sub _has_positions {
●3194 → 3199 → 3209 3194: 	my $input_spec = $_[0];
 3195: 
 3196: 	# Guard against undef or non-hash input — keys %$undef would throw
 3197: 	return 0 unless defined($input_spec) && ref($input_spec) eq 'HASH';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3198: 
 3199: 	for my $field (keys %{$input_spec}) {
 3200: 		# Only examine fields whose spec is a hashref — scalar specs
 3201: 		# (e.g. input: { type: string }) cannot have positions
 3202: 		next unless ref($input_spec->{$field}) eq 'HASH';
 3203: 
 3204: 		# Return immediately on first match — no need to scan further
 3205: 		return 1 if defined $input_spec->{$field}{position};
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3206: 	}
 3207: 
 3208: 	# No positional arguments found in any field
 3209: 	return 0;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3210: }
 3211: 
 3212: # --------------------------------------------------
 3213: # q_wrap
 3214: #
 3215: # Purpose:    Wrap a string in the most readable
 3216: #             q{} form that does not require escaping,
 3217: #             falling back to single-quoted form with
 3218: #             escaped apostrophes if no delimiter is
 3219: #             available.
 3220: #
 3221: # Entry:      $s - the string to wrap. May be undef.
 3222: # Exit:       Returns a Perl source-code fragment that
 3223: #             evaluates to the original string value,
 3224: #             or the string 'undef' if $s is undef.
 3225: #
 3226: # Notes:      index() returns -1 when not found and
 3227: #             any value >= 0 when found, including 0
 3228: #             for a delimiter at the start of the
 3229: #             string. We compare against $INDEX_NOT_FOUND
 3230: #             to make this boundary explicit and to
 3231: #             prevent off-by-one mutation survivors.
 3232: #             See GitHub issue #1.
 3233: # --------------------------------------------------
 3234: sub q_wrap {
●3235 → 3249 → 3258 3235: 	my $s = $_[0];
 3236: 
 3237: 	croak('q_wrap: argument must be a plain string, not a reference') if ref($s);
 3238: 
 3239: 	# Return empty string for undef — this function is a low-level
 3240: 	# string quoter only. Callers that need the Perl literal 'undef'
 3241: 	# for undefined values should use perl_quote() instead, which
 3242: 	# handles the undef -> 'undef' semantic conversion correctly.
 3243: 	# Returning '' here preserves the original behaviour and avoids
 3244: 	# injecting the bare word 'undef' into contexts that expect a
 3245: 	# quoted string value.
 3246: 	return "''" unless defined $s;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3247: 
 3248: 	# Try bracket-form q{} delimiters first — most readable
 3249: 	for my $p (@Q_BRACKET_PAIRS) {
 3250: 		my ($l, $r) = @{$p};
 3251: 
 3252: 		# Only use this bracket pair if neither bracket
 3253: 		# appears in the string — both must be checked
 3254: 		return "q$l$s$r" unless $s =~ /\Q$l\E|\Q$r\E/;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3255: 	}
 3256: 
 3257: 	# Try single-character delimiters in preference order
●3258 → 3258 → 3263 3258: 	for my $d (@Q_SINGLE_DELIMITERS) {
 3259: 		# index() returns $INDEX_NOT_FOUND (-1) when not found.
 3260: 		# Must use != $INDEX_NOT_FOUND rather than > 0 since
 3261: 		# the delimiter may legitimately appear at position 0
 3262: 		return "q$d$s$d" if index($s, $d) == $INDEX_NOT_FOUND;
  Mutants (Total: 3, Killed: 3, Survived: 0)
 3263: 	}
 3264: 
 3265: 	# Last resort — single-quoted string with escaped apostrophes
 3266: 	(my $esc = $s) =~ s/'/\\'/g;
 3267: 	return "'$esc'";

					

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

				
BOOL_NEGATE_3267_2: 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_3267_2: 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' );

								
							
 3268: }
 3269: 
 3270: # --------------------------------------------------
 3271: # perl_sq
 3272: #
 3273: # Purpose:    Escape a string for safe inclusion
 3274: #             inside a single-quoted Perl string
 3275: #             literal in generated test code.
 3276: #
 3277: # Entry:      $s - the string to escape.
 3278: # Exit:       Returns the escaped string, or an
 3279: #             empty string if $s is undef.
 3280: #
 3281: # Notes:      NUL byte replacement produces the
 3282: #             two-character sequence \0 which is
 3283: #             only correct when the result is used
 3284: #             inside a double-quoted string context
 3285: #             in the generated test.
 3286: #
 3287: #             The \b substitution (backspace) is
 3288: #             intentionally omitted — in Perl regex
 3289: #             context \b means word boundary, not
 3290: #             backspace, so substituting it here
 3291: #             would corrupt strings containing word
 3292: #             boundaries.
 3293: # --------------------------------------------------
 3294: sub perl_sq {
 3295: 	my $s = $_[0];
 3296: 
 3297: 	croak('perl_sq: argument must be a plain string, not a reference') if ref($s);
 3298: 
 3299: 	# Return empty string for undef — callers that need
 3300: 	# 'undef' literal should use perl_quote instead
 3301: 	return '' unless defined $s;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3302: 
 3303: 	# Escape backslashes first so later substitutions
 3304: 	# don't double-escape already-escaped sequences
 3305: 	$s =~ s/\\/\\\\/g;
 3306: 
 3307: 	# Escape apostrophes so they don't terminate the
 3308: 	# surrounding single-quoted string literal
 3309: 	$s =~ s/'/\\'/g;
 3310: 
 3311: 	# Escape common control characters to their
 3312: 	# printable two-character escape sequences
 3313: 	$s =~ s/\n/\\n/g;
 3314: 	$s =~ s/\r/\\r/g;
 3315: 	$s =~ s/\t/\\t/g;
 3316: 	$s =~ s/\f/\\f/g;
 3317: 
 3318: 	# Replace NUL bytes with \0 — valid only in
 3319: 	# double-quoted string context in generated code
 3320: 	$s =~ s/\0/\\0/g;
 3321: 
 3322: 	return $s;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3323: }
 3324: 
 3325: =head2 perl_quote
 3326: 
 3327: Convert any Perl value into a source-code fragment that reproduces that value
 3328: when evaluated in a generated test file.
 3329: 
 3330: =head3 Arguments
 3331: 
 3332: =over 4
 3333: 
 3334: =item * C<$v>
 3335: 
 3336: Any Perl value. May be undef, a scalar, an arrayref, a Regexp, or a blessed
 3337: object. All types are handled — undef becomes C<'undef'>, the strings
 3338: C<'true'>/C<'false'> become the Perl boolean constants C<!!1>/C<!!0>,
 3339: numbers are unquoted, other strings are single-quoted, arrayrefs recurse,
 3340: Regexps become C<qr{...}>, and anything else (including hashrefs and
 3341: blessed objects) falls through to C<render_fallback>.
 3342: 
 3343: =back
 3344: 
 3345: =head3 API specification
 3346: 
 3347: =head4 input
 3348: 
 3349:     { v => { type => 'any', optional => 1 } }
 3350: 
 3351: =head4 output
 3352: 
 3353:     { type => 'string' }
 3354: 
 3355: =cut
 3356: 
 3357: sub perl_quote {
 3358: 	my ($v) = @_;
 3359: 	return _perl_quote($v, 0);
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3360: }
 3361: 
 3362: sub _perl_quote {
●3363 → 3374 → 3398 3363: 	my ($v, $depth) = @_;
 3364: 	croak('perl_quote: structure too deeply nested (circular reference?)') if $depth > 100;
  Mutants (Total: 3, Killed: 3, Survived: 0)
 3365: 
 3366: 	# Undef produces the Perl literal 'undef'
 3367: 	return 'undef' unless defined $v;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3368: 
 3369: 	# Convert YAML boolean string literals to Perl
 3370: 	# boolean constants so they survive round-tripping
 3371: 	return '!!1' if $v eq 'true';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3372: 	return '!!0' if $v eq 'false';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3373: 
 3374: 	if(ref($v)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 3375: 		# Recursively quote each element of an arrayref
 3376: 		if(ref($v) eq 'ARRAY') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 3377: 			my @quoted_v = map { _perl_quote($_, $depth + 1) } @{$v};
 3378: 			return '[ ' . join(', ', @quoted_v) . ' ]';
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3379: 		}
 3380: 
 3381: 		# Render Regexp objects as qr{} with modifiers
 3382: 		if(ref($v) eq 'Regexp') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 3383: 			my ($pat, $mods) = regexp_pattern($v);
 3384: 			my $re = "qr{$pat}";
 3385: 
 3386: 			# Append modifiers (e.g. 'i', 'x') if present
 3387: 			$re .= $mods if $mods;
 3388: 			return $re;
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3389: 		}
 3390: 
 3391: 		# Hashrefs and other reference types fall through
 3392: 		# to render_fallback which uses Data::Dumper
 3393: 		return render_fallback($v);
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3394: 	}
 3395: 
 3396: 	# Numeric values are emitted unquoted so the generated
 3397: 	# test performs numeric rather than string comparison
 3398: 	return looks_like_number($v) ? $v : "'" . perl_sq($v) . "'";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 3399: }
 3400: 
 3401: # --------------------------------------------------
 3402: # _generate_transform_properties
 3403: #
 3404: # Convert a hashref of transform
 3405: #     specifications into an arrayref of
 3406: #     LectroTest property definition hashrefs,
 3407: #     one per transform. Each hashref contains
 3408: #     all the information needed by
 3409: #     _render_properties to emit a runnable
 3410: #     Test::LectroTest property block.
 3411: #
 3412: # Entry:      $transforms  - hashref of transform name
 3413: #                            => transform spec, as
 3414: #                            loaded from the schema.
 3415: #             $function    - name of the function under
 3416: #                            test.
 3417: #             $module      - module name, or undef for
 3418: #                            builtin functions.
 3419: #             $input       - the top-level input spec
 3420: #                            hashref from the schema
 3421: #                            (used for position sorting).
 3422: #             $config      - the normalised config
 3423: #                            hashref, used to read
 3424: #                            properties.trials.
 3425: #             $new         - defined if the function is
 3426: #                            an object method; the value
 3427: #                            is not used here since
 3428: #                            property tests always
 3429: #                            construct a fresh object
 3430: #                            via new_ok() with no args.
 3431: #                            Presence vs absence is the
 3432: #                            only signal used.
 3433: #
 3434: # Exit:       Returns an arrayref of property hashrefs.
 3435: #             Returns an empty arrayref if no transforms
 3436: #             produce any testable properties.
 3437: #             Never returns undef.
 3438: #
 3439: # Notes:      Transforms whose input is the string
 3440: #             'undef' or whose input spec is not a
 3441: #             hashref are silently skipped — they
 3442: #             represent error-case transforms that have
 3443: #             no meaningful generator.
 3444: #
 3445: #             The 'WARN' vs 'WARNS' distinction in
 3446: #             _STATUS: the schema convention uses
 3447: #             'WARNS' throughout. This function checks
 3448: #             for 'WARNS' to match that convention.
 3449: # --------------------------------------------------
 3450: sub _generate_transform_properties {
●3451 → 3455 → 3599 3451: 	my ($transforms, $function, $module, $input, $config, $new) = @_;
 3452: 
 3453: 	my @properties;
 3454: 
 3455: 	for my $transform_name (sort keys %{$transforms}) {
 3456: 		# $transform_name is spliced by _render_properties as a Perl
 3457: 		# *variable name* (my $$transform_name = Property {...}), not
 3458: 		# just inside a string literal — reject anything that isn't
 3459: 		# identifier-shaped before it reaches that point.
 3460: 		_assert_identifier($transform_name, 'transform name');
 3461: 
 3462: 		my $transform   = $transforms->{$transform_name};
 3463: 
 3464: 		my $input_spec  = $transform->{input};
 3465: 
 3466: 		# Guard: skip transforms with no input or with the
 3467: 		# YAML scalar 'undef' as their input — these have no
 3468: 		# generator and cannot produce meaningful properties
 3469: 		if(!defined($input_spec) ||
  Mutants (Total: 1, Killed: 1, Survived: 0)
 3470: 		   (!ref($input_spec) && $input_spec eq 'undef')) {
 3471: 			next;
 3472: 		}
 3473: 
 3474: 		# Guard: skip transforms whose input is not a hashref —
 3475: 		# must come before the helper calls below so we never
 3476: 		# pass a non-hash to _detect_transform_properties or
 3477: 		# _process_custom_properties
 3478: 		next unless ref($input_spec) eq 'HASH';
 3479: 
 3480: 		# Default output spec to empty hash so _STATUS lookups
 3481: 		# below are always safe regardless of schema content
 3482: 		my $output_spec = $transform->{output} // {};
 3483: 
 3484: 		# Detect automatic properties from the transform spec
 3485: 		# (range constraints, type preservation, definedness)
 3486: 		my @detected_props = _detect_transform_properties(
 3487: 			$transform_name,
 3488: 			$input_spec,
 3489: 			$output_spec
 3490: 		);
 3491: 
 3492: 		# Process any custom properties defined in the schema
 3493: 		my @custom_props = ();
 3494: 		if(exists($transform->{properties}) &&

					

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

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

 3495: 		   ref($transform->{properties}) eq 'ARRAY') {
 3496: 			@custom_props = _process_custom_properties(
 3497: 				$transform->{properties},
 3498: 				$function,
 3499: 				$module,
 3500: 				$input_spec,
 3501: 				$output_spec,
 3502: 				$new
 3503: 			);
 3504: 		}
 3505: 
 3506: 		# Combine auto-detected and custom properties into one list
 3507: 		my @all_props = (@detected_props, @custom_props);
 3508: 
 3509: 		# Skip this transform if no properties were produced —
 3510: 		# nothing useful to render into the generated test
 3511: 		next unless @all_props;
 3512: 
 3513: 		# Build the LectroTest generator specification string,
 3514: 		# one entry per input field that has a generator
 3515: 		my @generators;
 3516: 		my @var_names;
 3517: 
 3518: 		for my $field (sort keys %{$input_spec}) {
 3519: 			my $spec = $input_spec->{$field};
 3520: 
 3521: 			# Skip non-hashref field specs — scalar types
 3522: 			# like 'string' have no generator sub-structure
 3523: 			next unless ref($spec) eq 'HASH';
 3524: 
 3525: 			# $field is spliced unescaped into the generated
 3526: 			# LectroTest generator spec by
 3527: 			# _schema_to_lectrotest_generator() — reject anything
 3528: 			# that isn't identifier-shaped first.
 3529: 			_assert_identifier($field, 'input field name');
 3530: 
 3531: 			my $gen = _schema_to_lectrotest_generator($field, $spec);
 3532: 			if(defined($gen) && length($gen)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 3533: 				push @generators, $gen;
 3534: 				push @var_names, $field;
 3535: 			}
 3536: 		}
 3537: 
 3538: 		my $gen_spec = join(', ', @generators);
 3539: 
 3540: 		# Build the call expression for the function under test.
 3541: 		# Note: property tests always construct a fresh object
 3542: 		# via new_ok() with no constructor arguments, regardless
 3543: 		# of what $new holds in the caller — the intent here is
 3544: 		# to test the method in isolation, not with specific
 3545: 		# construction state.
 3546: 		my $call_code;
 3547: 		if($module && defined($new)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 3548: 			# OO mode — construct a fresh object for each trial
 3549: 			$call_code  = "my \$obj = new_ok('$module');";
 3550: 			$call_code .= "\$obj->$function";
 3551: 		} elsif($module && $module ne $MODULE_BUILTIN) {
 3552: 			# Functional mode with a named module
 3553: 			$call_code = "$module\::$function";
 3554: 		} else {
 3555: 			# Builtin or unqualified function call
 3556: 			$call_code = $function;
 3557: 		}
 3558: 
 3559: 		# Build the argument list, respecting positional order
 3560: 		# if the input spec declares positions
 3561: 		my @args;
 3562: 		if(_has_positions($input_spec)) {

					

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

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

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

					

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

				
BOOL_NEGATE_4111_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_4111_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' );

								
							
 4112: 		} elsif(!defined($max)) {
 4113: 			# Only min defined — generate min to min + range
 4114: 			return "$field_name <- Int(sized => sub { $min + int(rand($DEFAULT_GENERATOR_RANGE)) })";

					

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

				
BOOL_NEGATE_4114_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_4114_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' );

								
							
 4115: 		} else {
 4116: 			# Both defined — generate within [min, max]
 4117: 			my $range = $max - $min;
 4118: 			return "$field_name <- Int(sized => sub { $min + int(rand($range + 1)) })";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4119: 		}
 4120: 	}
 4121: 
 4122: 	# --------------------------------------------------
 4123: 	# Float / number generator
 4124: 	# --------------------------------------------------
●4125 → 4125 → 4175 4125: 	if($type eq 'number' || $type eq 'float') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4126: 		my $min = $spec->{'min'};
 4127: 		my $max = $spec->{'max'};
 4128: 
 4129: 		if(!defined($min) && !defined($max)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4130: 			# Unconstrained — symmetric range around zero
 4131: 			return "$field_name <- Float(sized => sub { rand($DEFAULT_GENERATOR_RANGE) - $DEFAULT_GENERATOR_RANGE / 2 })";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4132: 
 4133: 		} elsif(!defined($min)) {
 4134: 			# Only max defined — choose range based on sign of max
 4135: 			if($max == $ZERO_BOUNDARY) {
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4136: 				# max=0: negative numbers only
 4137: 				return "$field_name <- Float(sized => sub { -rand($DEFAULT_GENERATOR_RANGE) })";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4138: 			} elsif($max > $ZERO_BOUNDARY) {

					

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

				
NUM_BOUNDARY_4138_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_4138_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_4138_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' );

								
							
 4139: 				# Positive max: generate 0 to max
 4140: 				return "$field_name <- Float(sized => sub { rand($max) })";

					

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

				
BOOL_NEGATE_4140_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_4140_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' );

								
							
 4141: 			} else {
 4142: 				# Negative max: generate from (max - range) to max
 4143: 				return "$field_name <- Float(sized => sub { ($max - $DEFAULT_GENERATOR_RANGE) + rand($DEFAULT_GENERATOR_RANGE + $max) })";

					

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

				
BOOL_NEGATE_4143_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_4143_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' );

								
							
 4144: 			}
 4145: 
 4146: 		} elsif(!defined($max)) {
 4147: 			# Only min defined — choose range based on sign of min
 4148: 			if($min == $ZERO_BOUNDARY) {

					

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

				
NUM_BOUNDARY_4148_12_!=: 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_4148_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

 4149: 				# min=0: positive numbers only
 4150: 				return "$field_name <- Float(sized => sub { rand($DEFAULT_GENERATOR_RANGE) })";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4151: 			} elsif($min > $ZERO_BOUNDARY) {

					

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

				
NUM_BOUNDARY_4151_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_4151_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_4151_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' );

								
							
 4152: 				# Positive min: generate min to min + range
 4153: 				return "$field_name <- Float(sized => sub { $min + rand($DEFAULT_GENERATOR_RANGE) })";

					

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

				
BOOL_NEGATE_4153_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_4153_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' );

								
							
 4154: 			} else {
 4155: 				# Negative min: generate from min to min + range
 4156: 				return "$field_name <- Float(sized => sub { $min + rand(-$min + $DEFAULT_GENERATOR_RANGE) })";

					

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

				
BOOL_NEGATE_4156_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_4156_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' );

								
							
 4157: 			}
 4158: 
 4159: 		} else {
 4160: 			# Both min and max defined — validate then generate
 4161: 			my $range = $max - $min;
 4162: 			if($range <= $ZERO_BOUNDARY) {

					

					
Mutants (Total: 4, Killed: 1, Survived: 3)
					

				
NUM_BOUNDARY_4162_14_<: 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_4162_14_>: 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_4162_14_>=: 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' );

								
							
 4163: 				carp "Invalid range for '$field_name': min=$min, max=$max";
 4164: 				# Return undef rather than emitting a degenerate
 4165: 				# generator that would silently produce wrong values
 4166: 				return;
 4167: 			}
 4168: 			return "$field_name <- Float(sized => sub { $min + rand($range) })";

					

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

				
BOOL_NEGATE_4168_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_4168_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' );

								
							
 4169: 		}
 4170: 	}
 4171: 
 4172: 	# --------------------------------------------------
 4173: 	# String generator
 4174: 	# --------------------------------------------------
●4175 → 4175 → 4214 4175: 	if($type eq 'string') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4176: 		my $min_len = $spec->{'min'} // 0;
 4177: 		my $max_len = $spec->{'max'} // $DEFAULT_MAX_STRING_LEN;
 4178: 
 4179: 		# If a regex pattern is declared, delegate to
 4180: 		# Data::Random::String::Matches for pattern-aware generation
 4181: 		if(defined($spec->{'matches'})) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4182: 			my $pattern = $spec->{'matches'};
 4183: 
 4184: 			# Compile the pattern safely rather than splicing the raw
 4185: 			# string into qr/$pattern/ — the raw form lets a pattern
 4186: 			# containing an unescaped '/' break out of the qr//
 4187: 			# delimiter and inject arbitrary Perl into the generated
 4188: 			# test. regexp_pattern() decomposes the already-compiled
 4189: 			# Regexp object back into pattern text that is guaranteed
 4190: 			# to be a self-contained regex body, safe to re-embed.
 4191: 			my $compiled = ref($pattern) eq 'Regexp' ? $pattern : eval { qr/$pattern/ };
 4192: 			if($@ || !defined($compiled)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4193: 				carp "Invalid matches pattern '$pattern' for field '$field_name': $@";
 4194: 				return "$field_name <- String(length => [$min_len, $max_len])";

					

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

				
BOOL_NEGATE_4194_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_4194_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' );

								
							
 4195: 			}
 4196: 			my ($pat, $mods) = regexp_pattern($compiled);
 4197: 			my $safe_re = "qr{$pat}" . ($mods // '');
 4198: 
 4199: 			if(defined($spec->{'max'})) {

					

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

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

 4200: 				return "$field_name <- Gen { Data::Random::String::Matches->create_random_string({ regex => $safe_re, length => $spec->{'max'} }) }";

					

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

				
BOOL_NEGATE_4200_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_4200_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' );

								
							
 4201: 			} elsif(defined($spec->{'min'})) {
 4202: 				return "$field_name <- Gen { Data::Random::String::Matches->create_random_string({ regex => $safe_re, length => $spec->{'min'} }) }";

					

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

				
BOOL_NEGATE_4202_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_4202_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' );

								
							
 4203: 			} else {
 4204: 				return "$field_name <- Gen { Data::Random::String::Matches->create_random_string({ regex => $safe_re }) }";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4205: 			}
 4206: 		}
 4207: 
 4208: 		return "$field_name <- String(length => [$min_len, $max_len])";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4209: 	}
 4210: 
 4211: 	# --------------------------------------------------
 4212: 	# Boolean generator
 4213: 	# --------------------------------------------------
●4214 → 4214 → 4221 4214: 	if($type eq 'boolean') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4215: 		return "$field_name <- Bool";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4216: 	}
 4217: 
 4218: 	# --------------------------------------------------
 4219: 	# Arrayref generator
 4220: 	# --------------------------------------------------
●4221 → 4221 → 4232 4221: 	if($type eq 'arrayref') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
 4222: 		my $min_size = $spec->{'min'} // 0;
 4223: 		my $max_size = $spec->{'max'} // $DEFAULT_MAX_COLLECTION_SIZE;
 4224: 		return "$field_name <- List(Int, length => [$min_size, $max_size])";
  Mutants (Total: 2, Killed: 2, Survived: 0)
 4225: 	}
 4226: 
 4227: 	# --------------------------------------------------
 4228: 	# Hashref generator
 4229: 	# LectroTest has no built-in Hash generator so we
 4230: 	# use Elements over a pre-built list of hashrefs
 4231: 	# --------------------------------------------------
●4232 → 4232 → 4241 4232: 	if($type eq 'hashref') {

					

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

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

 4233: 		my $min_keys = $spec->{'min'} // 0;
 4234: 		my $max_keys = $spec->{'max'} // $DEFAULT_MAX_COLLECTION_SIZE;
 4235: 		return "$field_name <- Elements(map { my \%h; for (1..\$_) { \$h{'key'.\$_} = \$_ }; \\\%h } $min_keys..$max_keys)";

					

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

				
BOOL_NEGATE_4235_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_4235_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' );

								
							
 4236: 	}
 4237: 
 4238: 	# --------------------------------------------------
 4239: 	# Unknown type — fall back to String with a warning
 4240: 	# --------------------------------------------------
 4241: 	carp "Unknown type '$type' for '$field_name' LectroTest generator, using String";
 4242: 	return "$field_name <- String";

					

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

				
BOOL_NEGATE_4242_2: 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_4242_2: 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' );

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

					

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

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

 4564: 			my $pattern = $output_spec->{'matches'};
 4565: 
 4566: 			# See the matching comment in _schema_to_lectrotest_generator —
 4567: 			# compile first and re-embed via regexp_pattern() rather than
 4568: 			# splicing the raw string into qr/$pattern/, which would let
 4569: 			# an unescaped '/' break out of the delimiter.
 4570: 			my $compiled = ref($pattern) eq 'Regexp' ? $pattern : eval { qr/$pattern/ };
 4571: 			if($@ || !defined($compiled)) {

					

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

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

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

					

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

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

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