lib/App/Test/Generator/SchemaExtractor.pm

⬅ Previous Index Next ➡
Structural Coverage (Approximate)

TER1 (Statement): 85.43%
TER2 (Branch): 74.87%
TER3 (LCSAJ): 99.0% (284/287)
Approximate LCSAJ segments: 1887

LCSAJ Legend

● Covered — this LCSAJ path was executed during testing.

● Not covered — this LCSAJ path was never executed. These are the paths to focus on.

Multiple dots on a line indicate that multiple control-flow paths begin at that line. Hovering over any dot shows: 

        start → end → jump

Uncovered paths show [NOT COVERED] in the tooltip.

Mutant Testing Legend

Survived (tests missed this) Killed (tests detected this) No mutation 
    1: package App::Test::Generator::SchemaExtractor;
    2: 
    3: use strict;
    4: use warnings;
    5: use autodie qw(:all);
    6: 
    7: use App::Test::Generator::Model::Method;
    8: use App::Test::Generator::Analyzer::Complexity;
    9: use App::Test::Generator::Analyzer::Return;
   10: use App::Test::Generator::Analyzer::ReturnMeta;
   11: use App::Test::Generator::Analyzer::SideEffect;
   12: 
   13: use Carp qw(carp croak);
   14: use PPI;
   15: use Pod::Simple::Text;
   16: use File::Basename;
   17: use File::Path qw(make_path);
   18: use Params::Get;
   19: use Safe;
   20: use Scalar::Util qw(looks_like_number);
   21: use YAML::XS;
   22: use IPC::Open3;
   23: use JSON::MaybeXS qw(encode_json decode_json);
   24: use Readonly;
   25: use Symbol qw(gensym);
   26: 
   27: # --------------------------------------------------
   28: # Confidence score thresholds for input and output analysis
   29: # --------------------------------------------------
   30: Readonly my $CONFIDENCE_HIGH_THRESHOLD   => 60;
   31: Readonly my $CONFIDENCE_MEDIUM_THRESHOLD => 35;
   32: Readonly my $CONFIDENCE_LOW_THRESHOLD    => 15;
   33: 
   34: # --------------------------------------------------
   35: # Confidence level label strings
   36: # --------------------------------------------------
   37: Readonly my $LEVEL_HIGH     => 'high';
   38: Readonly my $LEVEL_MEDIUM   => 'medium';
   39: Readonly my $LEVEL_LOW      => 'low';
   40: Readonly my $LEVEL_VERY_LOW => 'very_low';
   41: Readonly my $LEVEL_NONE     => 'none';
   42: 
   43: # --------------------------------------------------
   44: # Analysis limits
   45: # --------------------------------------------------
   46: Readonly my $DEFAULT_MAX_PARAMETERS     => 20;
   47: Readonly my $DEFAULT_CONFIDENCE_THRESH  => 0.5;
   48: Readonly my $POD_WALK_LIMIT             => 200;
   49: Readonly my $SIGNATURE_TIMEOUT_SECS     => 3;
   50: Readonly my $MEMORY_LIMIT_BYTES         => 50_000_000;
   51: 
   52: # --------------------------------------------------
   53: # Numeric boundary values for test hint generation
   54: # --------------------------------------------------
   55: Readonly my $INT32_MAX => 2_147_483_647;
   56: 
   57: # --------------------------------------------------
   58: # Boolean return score thresholds
   59: # --------------------------------------------------
   60: Readonly my $BOOLEAN_SCORE_THRESHOLD => 30;
   61: 
   62: =head1 NAME
   63: 
   64: App::Test::Generator::SchemaExtractor - Extract test schemas from Perl modules
   65: 
   66: =head1 VERSION
   67: 
   68: Version 0.41
   69: 
   70: =cut
   71: 
   72: our $VERSION = '0.41';
   73: 
   74: =head1 SYNOPSIS
   75: 
   76: 	use App::Test::Generator::SchemaExtractor;
   77: 
   78: 	my $extractor = App::Test::Generator::SchemaExtractor->new(
   79: 		input_file => 'lib/MyModule.pm',
   80: 		output_dir => 'schemas/',
   81: 		verbose	=> 1,
   82: 	);
   83: 
   84: 	my $schemas = $extractor->extract_all();
   85: 
   86: =head1 DESCRIPTION
   87: 
   88: App::Test::Generator::SchemaExtractor analyzes Perl modules and generates
   89: structured YAML schema files suitable for automated test generation by L<App::Test::Generator>.
   90: This module employs
   91: static analysis techniques to infer parameter types, constraints, and
   92: method behaviors directly from your source code.
   93: 
   94: =head2 Analysis Methods
   95: 
   96: The extractor combines multiple analysis approaches for a comprehensive schema generation:
   97: 
   98: =over 4
   99: 
  100: =item * B<POD Documentation Analysis>
  101: 
  102: Parses embedded documentation to extract:
  103:   - Parameter names, types, and descriptions from =head2 sections
  104:   - Method signatures with positional parameters
  105:   - Return value specifications from "Returns:" sections
  106:   - Constraints (ranges, patterns, required/optional status)
  107:   - Semantic type detection (email, URL, filename)
  108: 
  109: =item * B<Code Pattern Detection>
  110: 
  111: Analyzes source code using PPI to identify:
  112:   - Method signatures and parameter extraction patterns
  113:   - Type validation (ref(), isa(), blessed())
  114:   - Constraint patterns (length checks, numeric comparisons, regex matches)
  115:   - Return statement analysis and value type inference
  116:   - Object instantiation requirements and accessor methods
  117: 
  118: =item * B<Signature Analysis>
  119: 
  120: Examines method declarations for:
  121:   - Parameter names and positional information
  122:   - Instance vs. class method detection
  123:   - Method modifiers (Moose-style before/after/around)
  124:   - Various parameter declaration styles (shift, @_ assignment)
  125: 
  126: =item * B<Heuristic Inference>
  127: 
  128: Applies Perl-specific domain knowledge:
  129:   - Boolean return detection from method names (is_*, has_*, can_*)
  130:   - Common Perl idioms and coding patterns
  131:   - Context awareness (scalar vs list, wantarray usage)
  132:   - Object-oriented patterns (constructors, accessors, chaining)
  133: 
  134: =back
  135: 
  136: =head2 Generated Schema Structure
  137: 
  138: The extracted schemas follow this YAML structure:
  139: 
  140:     function: method_name
  141:     module: Package::Name
  142:     input:
  143:       param1:
  144:         type: string
  145:         min: 3
  146:         max: 50
  147:         optional: 0
  148:         position: 0
  149:       param2:
  150:         type: integer
  151:         min: 0
  152:         max: 100
  153:         optional: 1
  154:         position: 1
  155:     output:
  156:       type: boolean
  157:       value: 1
  158:     new: Package::Name # if object instantiation required
  159:     config:
  160:       test_empty: 1
  161:       test_nuls: 0
  162:       test_undef: 0
  163:       test_non_ascii: 0
  164: 
  165: =head2 Advanced Detection Capabilities
  166: 
  167: =over 4
  168: 
  169: =item * B<Accessor Method Detection>
  170: 
  171: Automatically identifies getter, setter, and combined accessor methods
  172: by analyzing common patterns like C<return $self-E<gt>{property}> and
  173: C<$self-E<gt>{property} = $value>.
  174: 
  175: =item * B<Params::Get Integration>
  176: 
  177: Recognises parameters extracted via C<Params::Get::get_params('key', \@_)>,
  178: treating the quoted key as a named parameter equivalent to a traditional
  179: C<my ($self, $key) = @_> signature.  This prevents false positives from
  180: C<--strict-pod> when the method body never declares an explicit C<$key>
  181: variable.
  182: 
  183: =item * B<Direct-Index Self Style>
  184: 
  185: Recognises C<my $self = $_[0]> as a valid method-invocant pattern.  Parameters
  186: at C<$_[1]>, C<$_[2]>, etc. are extracted as positional parameters.  Without
  187: this, the signature fallback would incorrectly pick up C<my (...) = @_> from
  188: inner closures defined in the method body and treat those variables as the
  189: outer method's parameters.
  190: 
  191: =item * B<Boolean Return Inference>
  192: 
  193: Detects boolean-returning methods through multiple signals:
  194:   - Method name patterns (is_*, has_*, can_*)
  195:   - Return patterns (consistent 1/0 returns)
  196:   - POD descriptions ("returns true on success")
  197:   - Ternary operators with boolean results
  198: 
  199: =item * B<Context Awareness>
  200: 
  201: Identifies methods that use C<wantarray> and can return different
  202: values in scalar vs list context.
  203: 
  204: =item * B<Object Lifecycle Management>
  205: 
  206: Detects instance methods requiring object instantiation and
  207: automatically adds the C<new> field to schemas.
  208: 
  209: =item * B<Enhanced Object Detection>
  210: 
  211: The extractor includes sophisticated object detection capabilities that go beyond simple instance method identification:
  212: 
  213: =over 4
  214: 
  215: =item * B<Factory Method Recognition>
  216: 
  217: Automatically identifies methods that create and return object instances, such as methods named C<create_*>, C<make_*>, C<build_*>, or C<get_*>. Factory methods are correctly classified as class methods that don't require pre-existing objects for testing.
  218: 
  219: =item * B<Singleton Pattern Detection>
  220: 
  221: Recognizes singleton patterns through multiple signals: method names like C<instance> or C<get_instance>, static variables holding instance references, lazy initialization patterns (C<$instance ||= new()>), and consistent return of the same instance variable.
  222: 
  223: =item * B<Constructor Parameter Analysis>
  224: 
  225: Examines C<new> methods to determine required and optional parameters, validation requirements, and default values. This enables test generators to provide appropriate constructor arguments when object instantiation is needed.
  226: 
  227: =item * B<Inheritance Relationship Handling>
  228: 
  229: Detects parent classes through C<use parent>, C<use base>, and C<@ISA> declarations. Identifies when methods use C<SUPER::> calls and determines whether the current class or a parent class constructor should be used for object instantiation.
  230: 
  231: =item * B<External Object Dependency Detection>
  232: 
  233: Identifies when methods create or depend on objects from other classes, enabling proper test setup with mock objects or real dependencies.
  234: 
  235: =back
  236: 
  237: These enhancements ensure that generated test schemas accurately reflect the object-oriented structure of the code, leading to more meaningful and effective test generation.
  238: 
  239: =back
  240: 
  241: =head2 Confidence Scoring
  242: 
  243: Each generated schema includes detailed confidence assessments:
  244: 
  245: =over 4
  246: 
  247: =item * B<High Confidence>
  248: 
  249: Multiple independent analysis sources converge on consistent,
  250: well-constrained parameters with explicit validation logic and
  251: comprehensive documentation.
  252: 
  253: =item * B<Medium Confidence>
  254: 
  255: Reasonable evidence from code patterns or partial documentation,
  256: but may lack comprehensive constraints or have some ambiguities.
  257: 
  258: =item * B<Low Confidence>
  259: 
  260: Minimal evidence - primarily based on naming conventions,
  261: default assumptions, or single-source analysis.
  262: 
  263: =item * B<Very Low Confidence>
  264: 
  265: Barely any detectable signals - schema should be thoroughly
  266: reviewed before use in test generation.
  267: 
  268: =back
  269: 
  270: =head2 Use Cases
  271: 
  272: =over 4
  273: 
  274: =item * B<Automated Test Generation>
  275: 
  276: Generate comprehensive test suites with L<App::Test::Generator> using
  277: extracted schemas as input. The schemas provide the necessary structure
  278: for generating both positive and negative test cases.
  279: 
  280: =item * B<API Documentation Generation>
  281: 
  282: Supplement existing documentation with automatically inferred interface
  283: specifications, parameter requirements, and return types.
  284: 
  285: =item * B<Code Quality Assessment>
  286: 
  287: Identify methods with poor documentation, inconsistent parameter handling,
  288: or unclear interfaces that may benefit from refactoring.
  289: 
  290: =item * B<Refactoring Assistance>
  291: 
  292: Detect method dependencies, object instantiation requirements, and
  293: parameter usage patterns to inform refactoring decisions.
  294: 
  295: =item * B<Legacy Code Analysis>
  296: 
  297: Quickly understand the interface contracts of legacy Perl codebases
  298: without extensive manual code reading.
  299: 
  300: =back
  301: 
  302: =head2 Integration with Testing Ecosystem
  303: 
  304: The generated schemas are specifically designed to work with the
  305: L<App::Test::Generator> ecosystem:
  306: 
  307:     # Extract schemas from your module
  308:     my $extractor = App::Test::Generator::SchemaExtractor->new(...);
  309:     my $schemas = $extractor->extract_all();
  310: 
  311:     # Use with test generator (typically as separate steps)
  312:     # fuzz-harness-generator -r schemas/method_name.yml
  313: 
  314: =head2 Limitations and Considerations
  315: 
  316: =over 4
  317: 
  318: =item * B<Dynamic Code Patterns>
  319: 
  320: Highly dynamic code (string evals, AUTOLOAD, symbolic references)
  321: may not be fully detected by static analysis.
  322: 
  323: =item * B<Complex Validation Logic>
  324: 
  325: Sophisticated validation involving multiple parameters or external
  326: dependencies may require manual schema refinement.
  327: 
  328: =item * B<Confidence Heuristics>
  329: 
  330: Confidence scores are based on heuristics and should be reviewed
  331: by developers familiar with the codebase.
  332: 
  333: =item * B<Perl Idiom Recognition>
  334: 
  335: Some Perl-specific idioms may require custom pattern recognition
  336: beyond the built-in detectors.
  337: 
  338: =item * B<Documentation Dependency>
  339: 
  340: Analysis quality improves significantly with comprehensive POD
  341: documentation following consistent patterns.
  342: 
  343: =back
  344: 
  345: =head2 Best Practices for Optimal Results
  346: 
  347: =over 4
  348: 
  349: =item * B<Comprehensive POD Documentation>
  350: 
  351: Write detailed POD with explicit parameter documentation using
  352: consistent patterns like C<$param - type (constraints), description>.
  353: 
  354: =item * B<Consistent Coding Patterns>
  355: 
  356: Use consistent parameter validation patterns and method signatures
  357: throughout your codebase.
  358: 
  359: =item * B<Schema Review Process>
  360: 
  361: Review and refine automatically generated schemas, particularly
  362: those with low confidence scores.
  363: 
  364: =item * B<Descriptive Naming>
  365: 
  366: Use descriptive method and parameter names that clearly indicate
  367: purpose and expected types.
  368: 
  369: =item * B<Progressive Enhancement>
  370: 
  371: Start with automatically generated schemas and progressively
  372: refine them based on test results and code understanding.
  373: 
  374: =back
  375: 
  376: The module is particularly valuable for large codebases where manual schema
  377: creation would be prohibitively time-consuming, and for maintaining test
  378: coverage as code evolves through continuous integration pipelines.
  379: 
  380: =head2 Advanced Type Detection
  381: 
  382: The schema extractor includes enhanced type detection capabilities that identify specialized Perl types beyond basic strings and integers.
  383: L<DateTime> and L<Time::Piece> objects are detected through isa() checks and method call patterns, while date strings (ISO 8601, YYYY-MM-DD) and UNIX timestamps are recognized through regex validation and numeric range checks.
  384: File handles and file paths are identified via I/O operations and file test operators, coderefs are detected through ref() checks and invocation patterns, and enum-like parameters are extracted from validation code including regex patterns (C</^(a|b|c)$/>), hash lookups, grep statements, and if/elsif chains.
  385: These detected types are preserved in the generated YAML schemas with appropriate semantic annotations, enabling test generators to create more accurate and meaningful test cases.
  386: 
  387: =head3 Example Advanced Type Schema
  388: 
  389: For a method like:
  390: 
  391:     sub process_event {
  392:         my ($self, $timestamp, $status, $callback) = @_;
  393:         croak unless $timestamp > 1000000000;
  394:         croak unless $status =~ /^(active|pending|complete)$/;
  395:         croak unless ref($callback) eq 'CODE';
  396:         $callback->($timestamp, $status);
  397:     }
  398: 
  399: The extractor generates:
  400: 
  401:     ---
  402:     function: process_event
  403:     module: MyModule
  404:     input:
  405:       timestamp:
  406:         type: integer
  407:         # min: 0
  408:         # max: 2147483647
  409:         position: 0
  410:         _note: Unix timestamp
  411: 	semantic: unix_timestamp
  412:       status:
  413:         type: string
  414:         enum:
  415:           - active
  416:           - pending
  417:           - complete
  418:         position: 1
  419:         _note: 'Must be one of: active, pending, complete'
  420:       callback:
  421:         type: coderef
  422:         position: 2
  423:         _note: 'CODE reference - provide sub { } in tests'
  424: 
  425: =head1 RELATIONSHIP DETECTION
  426: 
  427: The schema extractor detects relationships and dependencies between parameters,
  428: enabling more sophisticated validation and test generation.
  429: 
  430: =head2 Relationship Types
  431: 
  432: =over 4
  433: 
  434: =item * B<mutually_exclusive>
  435: 
  436: Parameters that cannot be used together.
  437: 
  438:     die if $file && $content;  # Can't specify both
  439: 
  440: Generated schema:
  441: 
  442:     relationships:
  443:       - type: mutually_exclusive
  444:         params: [file, content]
  445:         description: Cannot specify both file and content
  446: 
  447: =item * B<required_group>
  448: 
  449: At least one parameter from the group must be specified (OR logic).
  450: 
  451:     die unless $id || $name;  # Must provide one
  452: 
  453: Generated schema:
  454: 
  455:     relationships:
  456:       - type: required_group
  457:         params: [id, name]
  458:         logic: or
  459:         description: Must specify either id or name
  460: 
  461: =item * B<conditional_requirement>
  462: 
  463: If one parameter is specified, another becomes required (IF-THEN logic).
  464: 
  465:     die if $async && !$callback;  # async requires callback
  466: 
  467: Generated schema:
  468: 
  469:     relationships:
  470:       - type: conditional_requirement
  471:         if: async
  472:         then_required: callback
  473:         description: When async is specified, callback is required
  474: 
  475: =item * B<dependency>
  476: 
  477: One parameter depends on another being present.
  478: 
  479:     die "Port requires host" if $port && !$host;
  480: 
  481: Generated schema:
  482: 
  483:     relationships:
  484:       - type: dependency
  485:         param: port
  486:         requires: host
  487:         description: port requires host to be specified
  488: 
  489: =item * B<value_constraint>
  490: 
  491: Specific value requirements between parameters.
  492: 
  493:     die if $ssl && $port != 443;  # ssl requires port 443
  494: 
  495: Generated schema:
  496: 
  497:     relationships:
  498:       - type: value_constraint
  499:         if: ssl
  500:         then: port
  501:         operator: ==
  502:         value: 443
  503:         description: When ssl is specified, port must equal 443
  504: 
  505: =item * B<value_conditional>
  506: 
  507: Parameter required when another has a specific value.
  508: 
  509:     die if $mode eq 'secure' && !$key;
  510: 
  511: Generated schema:
  512: 
  513:     relationships:
  514:       - type: value_conditional
  515:         if: mode
  516:         equals: secure
  517:         then_required: key
  518:         description: When mode equals 'secure', key is required
  519: 
  520: =back
  521: 
  522: =head2 Default Value Extraction
  523: 
  524: The extractor comprehensively extracts default values from both code and POD documentation:
  525: 
  526: =head3 Code Pattern Recognition
  527: 
  528: Extracts defaults from multiple Perl idioms:
  529: 
  530: =over 4
  531: 
  532: =item * Logical OR operator: C<$param = $param || 'default'>
  533: 
  534: =item * Defined-or operator: C<$param //= 'default'>
  535: 
  536: =item * Ternary operator: C<$param = defined $param ? $param : 'default'>
  537: 
  538: =item * Unless conditional: C<$param = 'default' unless defined $param>
  539: 
  540: =item * Chained defaults: C<$param = $param || $self->{_default} || 'fallback'>
  541: 
  542: =item * Multi-line patterns: C<$param = {} unless $param>
  543: 
  544: =back
  545: 
  546: =head3 POD Pattern Recognition
  547: 
  548: Extracts defaults from documentation:
  549: 
  550: =over 4
  551: 
  552: =item * Standard format: C<Default: 'value'>
  553: 
  554: =item * Alternative format: C<Defaults to: 'value'>
  555: 
  556: =item * Inline format: C<Optional, default: 'value'>
  557: 
  558: =item * Parameter lists: C<$param - type, default 'value'>
  559: 
  560: =back
  561: 
  562: =head3 Value Processing
  563: 
  564: Properly handles:
  565: 
  566: =over 4
  567: 
  568: =item * String literals with quotes and escape sequences
  569: 
  570: =item * Numeric values (integers and floats)
  571: 
  572: =item * Boolean values (true/false converted to 1/0)
  573: 
  574: =item * Empty data structures ([] and {})
  575: 
  576: =item * Special values (undef, __PACKAGE__)
  577: 
  578: =item * Complex expressions (preserved as-is when unevaluatable)
  579: 
  580: =item * Quote operators (q{}, qq{}, qw{})
  581: 
  582: =back
  583: 
  584: =head3 Type Inference
  585: 
  586: When a parameter has a default value but no explicit type annotation,
  587: the type is automatically inferred from the default:
  588: 
  589:     $options = {}        # inferred as hashref
  590:     $items = []          # inferred as arrayref
  591:     $count = 42          # inferred as integer
  592:     $ratio = 3.14        # inferred as number
  593:     $enabled = 1         # inferred as boolean
  594: 
  595: =head2 Context-Aware Return Analysis
  596: 
  597: The extractor provides comprehensive analysis of method return behavior,
  598: including context sensitivity, error handling conventions, and method chaining patterns.
  599: 
  600: When a method's POD contains a C<=head4 Output> block in
  601: L<Params::Validate::Strict> schema format, the C<type> declared there is
  602: used as the authoritative output type and takes precedence over all
  603: heuristic code analysis:
  604: 
  605:     =head4 Output
  606: 
  607:         {
  608:             type => 'hashref',
  609:         }
  610: 
  611: This is the recommended way to document methods whose return type would
  612: otherwise be misidentified (e.g. a method that returns C<$self-E<gt>{cache}>
  613: where the cache happens to hold a hashref).
  614: 
  615: Using parentheses as the outer container emits C<type: array>, indicating a
  616: list-returning method.  L<App::Test::Generator> 0.39+ (with L<Test::Returns>
  617: 0.03+) captures these results in list context automatically:
  618: 
  619:     =head4 Output
  620: 
  621:         (
  622:             {
  623:                 type => 'hashref',
  624:             },
  625:             ...
  626:         )
  627: 
  628: =head3 List vs Scalar Context Detection
  629: 
  630: Automatically detects methods that return different values based on calling context:
  631: 
  632:     sub get_items {
  633:         my $self = $_[0];
  634:         return wantarray ? @items : scalar(@items);
  635:     }
  636: 
  637: Detection captures:
  638: 
  639: =over 4
  640: 
  641: =item * C<_context_aware> flag - Method uses wantarray
  642: 
  643: =item * C<_list_context> - Type returned in list context (e.g., 'array')
  644: 
  645: =item * C<_scalar_context> - Type returned in scalar context (e.g., 'integer')
  646: 
  647: =back
  648: 
  649: Recognizes both ternary operator patterns and conditional return patterns.
  650: 
  651: =head3 Void Context Methods
  652: 
  653: Identifies methods that don't return meaningful values:
  654: 
  655: =over 4
  656: 
  657: =item * Setters (C<set_*> methods)
  658: 
  659: =item * Mutators (C<add_*, remove_*, delete_*, clear_*, reset_*, update_*>)
  660: 
  661: =item * Loggers (C<log, debug, warn, error, info>)
  662: 
  663: =item * Methods with only empty returns
  664: 
  665: =back
  666: 
  667: Example:
  668: 
  669:     sub set_name {
  670:         my ($self, $name) = @_;
  671:         $self->{name} = $name;
  672:         return;  # Void context
  673:     }
  674: 
  675: Sets C<_void_context> flag and C<type =E<gt> 'void'>.
  676: 
  677: =head3 Method Chaining Detection
  678: 
  679: Identifies chainable methods that return C<$self> for fluent interfaces:
  680: 
  681:     sub set_width {
  682:         my ($self, $width) = @_;
  683:         $self->{width} = $width;
  684:         return $self;  # Chainable
  685:     }
  686: 
  687: Detection provides:
  688: 
  689: =over 4
  690: 
  691: =item * C<_returns_self> - Returns invocant for chaining
  692: 
  693: =item * C<class> - The class name being returned
  694: 
  695: =back
  696: 
  697: Also detects chaining documentation in POD (keywords: "chainable", "fluent interface",
  698: "returns self", "method chaining").
  699: 
  700: =head3 Error Return Conventions
  701: 
  702: Analyzes how methods signal errors:
  703: 
  704: B<Pattern Detection:>
  705: 
  706: =over 4
  707: 
  708: =item * C<undef_on_error> - Explicit C<return undef if/unless condition>
  709: 
  710: =item * C<implicit_undef> - Bare C<return if/unless condition>
  711: 
  712: =item * C<empty_list> - C<return ()> for list context errors
  713: 
  714: =item * C<zero_on_error> - Returns 0/false for boolean error indication
  715: 
  716: =item * C<exception_handling> - Uses eval blocks with error checking
  717: 
  718: =back
  719: 
  720: B<Example Analysis:>
  721: 
  722:     sub fetch_user {
  723:         my ($self, $id) = @_;
  724: 
  725:         return undef unless $id;        # undef_on_error
  726:         return undef if $id < 0;        # undef_on_error
  727: 
  728:         return $self->{users}{$id};
  729:     }
  730: 
  731: Results in:
  732: 
  733:     _error_return: 'undef'
  734:     _success_failure_pattern: 1
  735:     _error_handling: {
  736:         undef_on_error: ['$id', '$id < 0']
  737:     }
  738: 
  739: B<Success/Failure Pattern:>
  740: 
  741: Methods that return different types for success vs. failure are flagged with
  742: C<_success_failure_pattern>. Common patterns:
  743: 
  744: =over 4
  745: 
  746: =item * Returns value on success, undef on failure
  747: 
  748: =item * Returns true on success, false on failure
  749: 
  750: =item * Returns data on success, empty list on failure
  751: 
  752: =back
  753: 
  754: =head3 Success Indicator Detection
  755: 
  756: Methods that always return true (typically for side effects):
  757: 
  758:     sub update_status {
  759:         my ($self, $status) = @_;
  760:         $self->{status} = $status;
  761:         return 1;  # Success indicator
  762:     }
  763: 
  764: Sets C<_success_indicator> flag when method consistently returns 1.
  765: 
  766: =head3 Schema Output
  767: 
  768: Enhanced return analysis adds these fields to method schemas:
  769: 
  770:     output:
  771:       type: boolean              # Inferred return type
  772:       _context_aware: 1           # Uses wantarray
  773:       _list_context:
  774:         type: array
  775:       _scalar_context:
  776:         type: integer
  777:       _returns_self: 1               # Returns $self
  778:       _void_context: 1            # No meaningful return
  779:       _success_indicator: 1       # Always returns true
  780:       _error_return: undef        # How errors are signaled
  781:       _success_failure_pattern: 1 # Mixed return types
  782:       _error_handling:            # Detailed error patterns
  783:         undef_on_error: [...]
  784:         exception_handling: 1
  785: 
  786: This comprehensive analysis enables:
  787: 
  788: =over 4
  789: 
  790: =item * Better test generation (testing both contexts, error paths)
  791: 
  792: =item * Documentation generation (clear error conventions)
  793: 
  794: =item * API design validation (consistent error handling)
  795: 
  796: =item * Contract specification (precise return behavior)
  797: 
  798: =back
  799: 
  800: =head2 Example
  801: 
  802: For a method like:
  803: 
  804:     sub connect {
  805:         my ($self, $host, $port, $ssl, $file, $content) = @_;
  806: 
  807:         die if $file && $content;                    # mutually exclusive
  808:         die unless $host || $file;                   # required group
  809:         die "Port requires host" if $port && !$host; # dependency
  810:         die if $ssl && $port != 443;                 # value constraint
  811: 
  812:         # ... connection logic
  813:     }
  814: 
  815: The extractor generates:
  816: 
  817:     relationships:
  818:       - type: mutually_exclusive
  819:         params: [file, content]
  820:         description: Cannot specify both file and content
  821:       - type: required_group
  822:         params: [host, file]
  823:         logic: or
  824:         description: Must specify either host or file
  825:       - type: dependency
  826:         param: port
  827:         requires: host
  828:         description: port requires host to be specified
  829:       - type: value_constraint
  830:         if: ssl
  831:         then: port
  832:         operator: ==
  833:         value: 443
  834:         description: When ssl is specified, port must equal 443
  835: 
  836: =head1 MODERN PERL FEATURES
  837: 
  838: This module adds support for:
  839: 
  840: =head2 Subroutine Signatures (Perl 5.20+)
  841: 
  842:     sub connect($host, $port = 3306, %options) {
  843:         ...
  844:     }
  845: 
  846: Extracts: required params, optional params with defaults, slurpy params
  847: 
  848: =head2 Type Constraints (Perl 5.36+)
  849: 
  850:     sub calculate($x :Int, $y :Num) {
  851:         ...
  852:     }
  853: 
  854: Recognizes: Int, Num, Str, Bool, ArrayRef, HashRef, custom classes
  855: 
  856: =head3 Subroutine Attributes
  857: 
  858:     sub get_value :lvalue :Returns(Int) {
  859:         ...
  860:     }
  861: 
  862: Detects: :lvalue, :method, :Returns(Type), custom attributes
  863: 
  864: =head2 Postfix Dereferencing (Perl 5.20+)
  865: 
  866:     my @array = $arrayref->@*;
  867:     my %hash = $hashref->%*;
  868:     my @slice = $arrayref->@[1,3,5];
  869: 
  870: Tracks usage of modern dereferencing syntax
  871: 
  872: =head2 Field Declarations (Perl 5.38+)
  873: 
  874:     field $host :param = 'localhost';
  875:     field $port :param(port_number) = 3306;
  876:     field $logger :param :isa(Log::Any);
  877: 
  878: Extracts fields and maps them to parameters
  879: 
  880: =head2 Modern Perl Features Support
  881: 
  882: The schema extractor supports modern Perl syntax introduced in versions 5.20, 5.36, and 5.38+.
  883: 
  884: =head3 Subroutine Signatures (Perl 5.20+)
  885: 
  886: Automatically extracts parameters from native Perl signatures:
  887: 
  888:     use feature 'signatures';
  889: 
  890:     sub connect($host, $port = 3306, $database = undef) {
  891:         ...
  892:     }
  893: 
  894: Extracted schema includes:
  895: 
  896: =over 4
  897: 
  898: =item * Parameter positions
  899: 
  900: =item * Optional vs required parameters
  901: 
  902: =item * Default values from signature
  903: 
  904: =item * Slurpy parameters (@array, %hash)
  905: 
  906: =back
  907: 
  908: B<Example:>
  909: 
  910:     # Signature with defaults
  911:     sub process($file, %options) { ... }
  912: 
  913:     # Extracts:
  914:     # $file: position 0, required
  915:     # %options: position 1, optional, slurpy hash
  916: 
  917: =head3 Type Constraints in Signatures (Perl 5.36+)
  918: 
  919: Recognizes type constraints in signature parameters:
  920: 
  921:     sub calculate($x :Int, $y :Num, $name :Str = "result") {
  922:         return $x + $y;
  923:     }
  924: 
  925: Supported constraint types:
  926: 
  927: =over 4
  928: 
  929: =item * C<:Int, :Integer> -> integer
  930: 
  931: =item * C<:Num, :Number> -> number
  932: 
  933: =item * C<:Str, :String> -> string
  934: 
  935: =item * C<:Bool, :Boolean> -> boolean
  936: 
  937: =item * C<:ArrayRef, :Array> -> arrayref
  938: 
  939: =item * C<:HashRef, :Hash> -> hashref
  940: 
  941: =item * C<:ClassName> -> object with isa constraint
  942: 
  943: =back
  944: 
  945: Type constraints are combined with defaults when both are present.
  946: 
  947: =head3 Subroutine Attributes
  948: 
  949: Extracts and documents subroutine attributes:
  950: 
  951:     sub get_value :lvalue {
  952:         my $self = shift;
  953:         return $self->{value};
  954:     }
  955: 
  956:     sub calculate :Returns(Int) :method {
  957:         my ($self, $x, $y) = @_;
  958:         return $x + $y;
  959:     }
  960: 
  961: Recognized attributes stored in C<_attributes> field:
  962: 
  963: =over 4
  964: 
  965: =item * C<:lvalue> - Method can be assigned to
  966: 
  967: =item * C<:method> - Explicitly marked as method
  968: 
  969: =item * C<:Returns(Type)> - Declares return type
  970: 
  971: =item * Custom attributes with values: C<:MyAttr(value)>
  972: 
  973: =back
  974: 
  975: =head3 Postfix Dereferencing (Perl 5.20+)
  976: 
  977: Detects usage of postfix dereferencing syntax:
  978: 
  979:     use feature 'postderef';
  980: 
  981:     sub process_array {
  982:         my ($self, $arrayref) = @_;
  983:         my @array = $arrayref->@*;        # Array dereference
  984:         my @slice = $arrayref->@[1,3,5];  # Array slice
  985:         return @array;
  986:     }
  987: 
  988:     sub process_hash {
  989:         my ($self, $hashref) = @_;
  990:         my %hash = $hashref->%*;          # Hash dereference
  991:         return keys %hash;
  992:     }
  993: 
  994: Tracked features stored in C<_modern_features>:
  995: 
  996: =over 4
  997: 
  998: =item * C<array_deref> - Uses C<-E<gt>@*>
  999: 
 1000: =item * C<hash_deref> - Uses C<-E<gt>%*>
 1001: 
 1002: =item * C<scalar_deref> - Uses C<-E<gt>$*>
 1003: 
 1004: =item * C<code_deref> - Uses C<-E<gt>&*>
 1005: 
 1006: =item * C<array_slice> - Uses C<-E<gt>@[...]>
 1007: 
 1008: =item * C<hash_slice> - Uses C<-E<gt>%{...}>
 1009: 
 1010: =back
 1011: 
 1012: =head3 Field Declarations (Perl 5.38+)
 1013: 
 1014: Extracts field declarations from class syntax and maps them to method parameters:
 1015: 
 1016:     use feature 'class';
 1017: 
 1018:     class DatabaseConnection {
 1019:         field $host :param = 'localhost';
 1020:         field $port :param = 3306;
 1021:         field $username :param(user);
 1022:         field $password :param;
 1023:         field $logger :param :isa(Log::Any);
 1024: 
 1025:         method connect() {
 1026:             # Fields available as instance variables
 1027:         }
 1028:     }
 1029: 
 1030: Field attributes:
 1031: 
 1032: =over 4
 1033: 
 1034: =item * C<:param> - Field is a constructor parameter (uses field name)
 1035: 
 1036: =item * C<:param(name)> - Field maps to parameter with different name
 1037: 
 1038: =item * C<:isa(Class)> - Type constraint for the field
 1039: 
 1040: =item * Default values in field declarations
 1041: 
 1042: =back
 1043: 
 1044: Extracted schema includes both field information in C<_fields> and merged parameter
 1045: information in C<input>, allowing proper validation of class constructors.
 1046: 
 1047: =head3 Mixed Modern and Traditional Syntax
 1048: 
 1049: The extractor handles code that mixes modern and traditional syntax:
 1050: 
 1051:     sub modern($x, $y = 5) {
 1052:         # Modern signature with default
 1053:     }
 1054: 
 1055:     sub traditional {
 1056:         my ($self, $x, $y) = @_;
 1057:         $y //= 5;  # Traditional default in code
 1058:         # Both extract same parameter information
 1059:     }
 1060: 
 1061: Priority order for parameter information:
 1062: 
 1063: =over 4
 1064: 
 1065: =item 1. Signature declarations (highest priority)
 1066: 
 1067: =item 2. Field declarations (for class methods)
 1068: 
 1069: =item 3. POD documentation
 1070: 
 1071: =item 4. Code analysis (lowest priority)
 1072: 
 1073: =back
 1074: 
 1075: This ensures that explicit declarations in signatures take precedence over
 1076: inferred information from code analysis.
 1077: 
 1078: =head3 Backwards Compatibility
 1079: 
 1080: All modern Perl feature detection is optional and automatic:
 1081: 
 1082: =over 4
 1083: 
 1084: =item * Traditional C<sub> declarations continue to work
 1085: 
 1086: =item * Code without modern features extracts parameters as before
 1087: 
 1088: =item * Modern features are additive - they enhance rather than replace existing extraction
 1089: 
 1090: =item * Schemas include C<_source> field indicating where parameter info came from
 1091: 
 1092: =back
 1093: 
 1094: =head2 _yamltest_hints
 1095: 
 1096: Each method schema returned by L</extract_all> now optionally includes a
 1097: C<_yamltest_hints> key, which provides guidance for automated test generation
 1098: based on the code analysis.
 1099: 
 1100: This is intended to help L<App::Test::Generator> create meaningful tests,
 1101: including boundary and invalid input cases, without manually specifying them.
 1102: 
 1103: The structure is a hashref with the following keys:
 1104: 
 1105: =over 4
 1106: 
 1107: =item * boundary_values
 1108: 
 1109: An arrayref of numeric values that represent boundaries detected from
 1110: comparisons in the code. These are derived from literals in statements
 1111: like C<$x < 0> or C<$y >= 255>. The generator can use these to create
 1112: boundary tests.
 1113: 
 1114: Example:
 1115: 
 1116:     _yamltest_hints:
 1117:       boundary_values: [0, 1, 100, 255]
 1118: 
 1119: =item * invalid_inputs
 1120: 
 1121: An arrayref of values that are likely to be rejected by the method,
 1122: based on checks like C<defined>, empty strings, or numeric validations.
 1123: 
 1124: Example:
 1125: 
 1126:     _yamltest_hints:
 1127:       invalid_inputs: [undef, '', -1]
 1128: 
 1129: =item * equivalence_classes
 1130: 
 1131: An arrayref intended to capture detected equivalence classes or patterns
 1132: among inputs. Currently this is empty by default, but future enhancements
 1133: may populate it based on detected input groupings.
 1134: 
 1135: Example:
 1136: 
 1137:     _yamltest_hints:
 1138:       equivalence_classes: []
 1139: 
 1140: =back
 1141: 
 1142: =head3 Usage
 1143: 
 1144: When calling C<extract_all>, each method schema will include
 1145: C<_yamltest_hints> if any hints were detected:
 1146: 
 1147:     my $schemas = $extractor->extract_all;
 1148:     my $hints  = $schemas->{example_method}->{_yamltest_hints};
 1149: 
 1150: You can then feed these hints into automated test generators to produce
 1151: negative tests, boundary tests, and parameter-specific test cases.
 1152: 
 1153: =head3 Notes
 1154: 
 1155: =over 4
 1156: 
 1157: =item * Hints are inferred heuristically from code and validation statements.
 1158: 
 1159: =item * Not all inputs are guaranteed to be detected; the feature is additive
 1160: and will never remove information from the schema.
 1161: 
 1162: =item * Currently, equivalence classes are not populated, but the field exists
 1163: for future extension.
 1164: 
 1165: =item * Boundary and invalid input hints are deduplicated to avoid repeated
 1166: test values.
 1167: 
 1168: =back
 1169: 
 1170: =head3 Examples
 1171: 
 1172: Given a method like:
 1173: 
 1174:     sub example {
 1175:         my ($x) = @_;
 1176:         die "negative" if $x < 0;
 1177:         return unless defined($x);
 1178:         return $x * 2;
 1179:     }
 1180: 
 1181: After running:
 1182: 
 1183:     my $extractor = App::Test::Generator::SchemaExtractor->new(
 1184:         input_file => 'TestHints.pm',
 1185:         output_dir => '/tmp',
 1186:         quiet    => 1,
 1187:     );
 1188: 
 1189:     my $schemas = $extractor->extract_all;
 1190: 
 1191: The schema for the method "example" will include:
 1192: 
 1193:     $schemas->{example} = {
 1194:         function => 'example',
 1195:         _confidence => {
 1196:             input  => 'unknown',
 1197:             output => 'unknown',
 1198:         },
 1199:         input => {
 1200:             x => {
 1201:                 type     => 'scalar',
 1202:                 optional => 0,
 1203:             }
 1204:         },
 1205:         output => {
 1206:             type => 'scalar',
 1207:         },
 1208:         _yamltest_hints => {
 1209:             boundary_values => [0, 1],
 1210:             invalid_inputs  => [undef, -1],
 1211:             equivalence_classes => [],
 1212:         },
 1213:         _notes => '...',
 1214:         _analysis => {
 1215:             input_confidence  => 'low',
 1216:             output_confidence => 'unknown',
 1217:             confidence_factors => {
 1218:                 input  => {...},
 1219:                 output => {...},
 1220:             },
 1221:             overall_confidence => 'low',
 1222:         },
 1223:         _fields => {},
 1224:         _modern_features => {},
 1225:         _attributes => {},
 1226:     };
 1227: 
 1228: =head1 METHODS
 1229: 
 1230: =head2 new
 1231: 
 1232: Construct a new SchemaExtractor for a given Perl source file.
 1233: 
 1234:     my $extractor = App::Test::Generator::SchemaExtractor->new(
 1235:         input_file           => 'lib/MyModule.pm',  # Required
 1236:         output_dir           => 'schemas/',         # Optional - only needed if writing schemas
 1237:         verbose              => 1,                  # Default: 0
 1238:         include_private      => 1,                  # Default: 0
 1239:         max_parameters       => 50,                 # Default: 20
 1240:         confidence_threshold => 0.7,               # Default: 0.5
 1241:         strict_pod           => 0|1|2,              # Default: 0 (off)
 1242:         allow_signature_exec => 1,                  # Default: 0 (off)
 1243:     );
 1244: 
 1245: =head3 Arguments
 1246: 
 1247: =over 4
 1248: 
 1249: =item * C<$input_file>
 1250: 
 1251: Path to the Perl source file to analyse. Required. Must exist on disk.
 1252: 
 1253: =item * C<output_dir>
 1254: 
 1255: Directory to write generated schema YAML files. Optional - only
 1256: required if C<_write_schema> will be called. Callers passing
 1257: C<no_write =E<gt> 1> to C<extract_all> do not need to supply it.
 1258: 
 1259: =item * C<verbose>
 1260: 
 1261: Print progress messages to stdout during analysis. Optional, default 0.
 1262: 
 1263: =item * C<include_private>
 1264: 
 1265: Include methods whose names begin with C<_> in the analysis. Optional,
 1266: default 0. Methods whose name begins with C<_new>, C<_init>, or
 1267: C<_build> are always included regardless of this setting (a prefix
 1268: match, so e.g. C<_build_attribute> and C<_init_logger> qualify too,
 1269: matching common Moose builder/initializer naming conventions).
 1270: 
 1271: =item * C<max_parameters>
 1272: 
 1273: Safety limit on the number of parameters analysed per method to prevent
 1274: runaway processing on pathological code. Optional, default 20.
 1275: 
 1276: =item * C<confidence_threshold>
 1277: 
 1278: Minimum confidence score (0.0-1.0) below which a schema is marked with
 1279: C<_low_confidence =E<gt> 1>. Optional, default 0.5.
 1280: 
 1281: =item * C<strict_pod>
 1282: 
 1283: Controls POD/code agreement validation. C<0> disables validation,
 1284: C<1> emits warnings, C<2> croaks on first disagreement. Also accepts
 1285: the strings C<off>, C<warn>, and C<fatal>. Optional, default 0.
 1286: 
 1287: =item * C<allow_signature_exec>
 1288: 
 1289: Opt-in flag allowing extraction of parameter types from a
 1290: L<Type::Params> C<signature_for()> declaration. This requires actually
 1291: running the C<signature_for> expression (sliced from the target
 1292: module's own source) in a forked C<perl -T> process, since
 1293: L<Type::Params> types are runtime objects that cannot be introspected
 1294: statically. Every other extraction path in this module is static
 1295: (L<PPI>-only) analysis that never executes any of the target module's
 1296: code; this is the one exception. Optional, default 0 (the
 1297: C<signature_for> path is silently skipped, with a warning under
 1298: C<verbose>, when off). Only enable this for modules whose code you
 1299: already trust enough to execute.
 1300: 
 1301: =back
 1302: 
 1303: =head3 Returns
 1304: 
 1305: A blessed hashref. Croaks if C<input_file> is missing or does not
 1306: exist on disk.
 1307: 
 1308: =head3 Side effects
 1309: 
 1310: Reads and parses the input file using L<PPI> at construction time.
 1311: 
 1312: =head3 API specification
 1313: 
 1314: =head4 input
 1315: 
 1316:     {
 1317:         input_file           => { type => SCALAR },
 1318:         output_dir           => { type => SCALAR,  optional => 1 },
 1319:         verbose              => { type => SCALAR,  optional => 1 },
 1320:         include_private      => { type => SCALAR,  optional => 1 },
 1321:         max_parameters       => { type => SCALAR,  optional => 1 },
 1322:         confidence_threshold => { type => SCALAR,  optional => 1 },
 1323:         strict_pod           => { type => SCALAR,  optional => 1 },
 1324:         allow_signature_exec => { type => SCALAR,  optional => 1 },
 1325:     }
 1326: 
 1327: =head4 output
 1328: 
 1329:     {
 1330:         type => OBJECT,
 1331:         isa  => 'App::Test::Generator::SchemaExtractor',
 1332:     }
 1333: 
 1334: =cut
 1335: 
 1336: sub new {
●1337 → 1358 → 1362 1337: 	my $class = shift;
 1338: 
 1339: 	# Handle hash or hashref arguments
 1340: 	my $params = Params::Get::get_params('input_file', @_) || {};
 1341: 
 1342: 	croak(__PACKAGE__, ': input_file required') unless exists $params->{input_file};
 1343: 
 1344: 	my $self = {
 1345: 		input_file => $params->{input_file},
 1346: 		# output_dir is optional — only required if _write_schema will be called.
 1347: 		# Callers using extract_all(no_write => 1) do not need to supply it.
 1348: 		output_dir => $params->{output_dir},
 1349: 		verbose	=> $params->{verbose} // 0,
 1350: 		include_private => $params->{include_private} // 0,	# include _private methods
 1351: 		confidence_threshold => $params->{confidence_threshold} // $DEFAULT_CONFIDENCE_THRESH,
 1352: 		max_parameters       => $params->{max_parameters}       // $DEFAULT_MAX_PARAMETERS,	# safety limit
 1353: 		strict_pod => _validate_strictness_level($params->{strict_pod}),	# Enable strict POD checking
 1354: 		allow_signature_exec => $params->{allow_signature_exec} // 0,	# opt-in: execute Type::Params signature_for() exprs from the target module
 1355: 	};
 1356: 
 1357: 	# Validate input file exists
 1358: 	unless (-f $self->{input_file}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1359: 		croak(__PACKAGE__, ": Input file '$self->{input_file}' does not exist");
 1360: 	}
 1361: 
 1362: 	return bless $self, $class;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1363: }
 1364: 
 1365: =head2 extract_all
 1366: 
 1367: Extract schemas for all qualifying methods in the module and return
 1368: them as a hashref.
 1369: 
 1370:     my $schemas = $extractor->extract_all();
 1371: 
 1372:     # Suppress writing .yml files to disk
 1373:     my $schemas = $extractor->extract_all(no_write => 1);
 1374: 
 1375: =head3 Arguments
 1376: 
 1377: =over 4
 1378: 
 1379: =item * C<no_write>
 1380: 
 1381: When true, schema files are not written to C<output_dir>. The returned
 1382: hashref is still fully populated. Useful when the caller wants to
 1383: inspect or augment schemas before deciding whether to write them.
 1384: Optional, default 0.
 1385: 
 1386: =back
 1387: 
 1388: =head3 Returns
 1389: 
 1390: A hashref mapping method name strings to schema hashrefs. Each schema
 1391: contains at minimum the keys C<function>, C<module>, C<input>,
 1392: C<output>, and C<_analysis>. See L</Generated Schema Structure> for
 1393: the full structure.
 1394: 
 1395: =head3 Side effects
 1396: 
 1397: Parses the input file with L<PPI>. Writes one YAML file per method to
 1398: C<output_dir> unless C<no_write> is set. Creates C<output_dir> if it
 1399: does not exist and writing is enabled.
 1400: 
 1401: =head3 Notes
 1402: 
 1403: Private methods (names beginning with C<_>) are excluded unless
 1404: C<include_private =E<gt> 1> was passed to C<new>. Duplicate method
 1405: names are deduplicated with a warning logged to stdout in verbose mode.
 1406: 
 1407: POD/code agreement validation is applied if C<strict_pod> was set in
 1408: C<new>. At level 2 (fatal), the first disagreement causes an immediate
 1409: croak.
 1410: 
 1411: =head3 API specification
 1412: 
 1413: =head4 input
 1414: 
 1415:     {
 1416:         self     => { type => OBJECT, isa => 'App::Test::Generator::SchemaExtractor' },
 1417:         no_write => { type => SCALAR, optional => 1 },
 1418:     }
 1419: 
 1420: =head4 output
 1421: 
 1422:     {
 1423:         type => HASHREF,
 1424:         keys => {
 1425:             '*' => {
 1426:                 type => HASHREF,
 1427:                 keys => {
 1428:                     function  => { type => SCALAR  },
 1429:                     module    => { type => SCALAR  },
 1430:                     input     => { type => HASHREF },
 1431:                     output    => { type => HASHREF },
 1432:                     _analysis => { type => HASHREF },
 1433:                 },
 1434:             },
 1435:         },
 1436:     }
 1437: 
 1438: =cut
 1439: 
 1440: sub extract_all {
●1441 → 1460 → 1472 1441: 	my $self = shift;
 1442: 	my $params = Params::Get::get_params(undef, @_) || {};
 1443: 
 1444: 	$self->_log("Parsing $self->{input_file}...");
 1445: 	$self->_log('Strict POD mode: ' . (qw(off warn fatal))[$self->{strict_pod}]);
 1446: 
 1447: 	my $document = PPI::Document->new($self->{input_file}) or die "Failed to parse $self->{input_file}: $!";
 1448: 
 1449: 	# Store document for later use
 1450: 	$self->{_document} = $document;
 1451: 
 1452: 	my $package_name = $self->_extract_package_name($document);
 1453: 	$self->{_package_name} //= $package_name;
 1454: 	$self->_log("Package: $package_name");
 1455: 
 1456: 	my $methods = $self->_find_methods($document);
 1457: 	$self->_log('Found ' . scalar(@$methods) . ' methods (pre-dedup)');
 1458: 
 1459: 	my %schemas;
 1460: 	foreach my $method (@{$methods}) {
 1461: 		$self->_log("\nAnalyzing method: $method->{name}");
 1462: 
 1463: 		my $schema = $self->_analyze_method($method);
 1464: 		$schemas{$method->{name}} = $schema;
 1465: 		$schema->{'module'} = $package_name;
 1466: 
 1467: 		# Write individual schema file
 1468: 		# Only write schema files if no_write is not set
 1469: 		$self->_write_schema($method->{name}, $schema) unless $params->{no_write};
 1470: 	}
 1471: 
 1472: 	return \%schemas;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1473: }
 1474: 
 1475: # --------------------------------------------------
 1476: # _extract_package_name
 1477: #
 1478: # Purpose:    Extract the Perl package name from a
 1479: #             PPI document, or from the cached value
 1480: #             stored at construction time.
 1481: #
 1482: # Entry:      $document - a PPI::Document, or undef
 1483: #                         to use $self->{_document}.
 1484: #
 1485: # Exit:       Returns the package namespace string,
 1486: #             or an empty string if no package
 1487: #             statement is found.
 1488: #
 1489: # Side effects: Stores the package name in
 1490: #               $self->{_package_name} if not already
 1491: #               set.
 1492: #
 1493: # Notes:      Croaks if more than one package
 1494: #             declaration is found — multi-package
 1495: #             files are not supported.
 1496: # --------------------------------------------------
 1497: sub _extract_package_name {
●1498 → 1500 → 1503 1498: 	my ($self, $document) = @_;
 1499: 
 1500: 	if(!defined($document)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1501: 		$document = $self->{_document};
 1502: 	}
●1503 → 1504 → 1508 1503: 	my $pkgs = $document->find('PPI::Statement::Package') || [];
 1504: 	if(@$pkgs == 0) {

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1505: 		my $package_stmt = $document->find_first('PPI::Statement::Package');
 1506: 		return $package_stmt ? $package_stmt->namespace() : '';

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1507: 	}
 1508: 	croak('More than one package declaration found') if @$pkgs > 1;

					

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

 1509: 	$self->{_package_name} //= $pkgs->[0]->namespace();
 1510: 	return $pkgs->[0]->namespace();

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1511: }
 1512: 
 1513: # --------------------------------------------------
 1514: # _find_methods
 1515: #
 1516: # Purpose:    Locate all subroutine and method
 1517: #             declarations in a PPI document,
 1518: #             including Moose-style method modifiers
 1519: #             and Perl 5.38 class/method syntax.
 1520: #
 1521: # Entry:      $document - a PPI::Document.
 1522: #
 1523: # Exit:       Returns an arrayref of method hashrefs,
 1524: #             each containing: name, node, body, pod,
 1525: #             type, and optionally modifier, class,
 1526: #             and fields keys.
 1527: #             Private methods (names beginning with
 1528: #             _) are excluded unless include_private
 1529: #             was set in new(), except for _new,
 1530: #             _init, and _build which are always
 1531: #             included.
 1532: #
 1533: # Side effects: Logs progress and warnings to stdout
 1534: #               when verbose is set.
 1535: #
 1536: # Notes:      Duplicate method names are silently
 1537: #             deduplicated — the second occurrence
 1538: #             is dropped with a verbose warning.
 1539: #             Class/method detection is regex-based
 1540: #             and may misbehave on complex code.
 1541: # --------------------------------------------------
 1542: sub _find_methods {
●1543 → 1549 → 1573 1543: 	my ($self, $document) = @_;
 1544: 
 1545: 	my $subs = $document->find('PPI::Statement::Sub') || [];
 1546: 	my $sub_decls = $document->find('PPI::Statement') || [];
 1547: 
 1548: 	my @methods;
 1549: 	foreach my $sub (@$subs) {
 1550: 		my $name = $sub->name();
 1551: 
 1552: 		next unless defined $name;	# Skip anonymous routines
 1553: 		next if $name =~ /^(BEGIN|END|DESTROY|AUTOLOAD|CHECK|INIT|UNITCHECK)$/;
 1554: 
 1555: 		# Skip private methods unless explicitly included, or they're special
 1556: 		if ($name =~ /^_/ && $name !~ /^_(new|init|build)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1557: 			next unless $self->{include_private};
 1558: 		}
 1559: 
 1560: 		# Get the POD before this sub
 1561: 		my $pod = $self->_extract_pod_before($sub);
 1562: 
 1563: 		push @methods, {
 1564: 			name => $name,
 1565: 			node => $sub,
 1566: 			body => $sub->content(),
 1567: 			pod => $pod,
 1568: 			type => 'sub',
 1569: 		};
 1570: 	}
 1571: 
 1572: 	# Look for class { method } syntax (Perl 5.38+)
●1573 → 1574 → 1580 1573: 	my $content = $document->content();
 1574: 	if ($content =~ /\bclass\b/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1575: 		$self->_log('  Detecting class/method syntax...');
 1576: 		$self->_extract_class_methods($content, \@methods);
 1577: 	}
 1578: 
 1579: 	# Process method modifiers (Moose)
●1580 → 1580 → 1609 1580: 	foreach my $decl (@$sub_decls) {
 1581: 		my $content = $decl->content;
 1582: 		if ($content =~ /^\s*(before|after|around)\s+['"]?(\w+)['"]?\b/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1583: 			my ($modifier, $method_name) = ($1, $2);
 1584: 			my $full_name = "${modifier}_$method_name";
 1585: 
 1586: 			# Look for the actual sub definition that follows
 1587: 			my $next_sib = $decl->next_sibling;
 1588: 			while ($next_sib && !$next_sib->isa('PPI::Statement::Sub')) {
 1589: 				$next_sib = $next_sib->next_sibling;
 1590: 			}
 1591: 
 1592: 			if ($next_sib && $next_sib->isa('PPI::Statement::Sub')) {

					

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

 1593: 				my $pod = $self->_extract_pod_before($decl); # POD might be before modifier
 1594: 				push @methods, {
 1595: 					name => $full_name,
 1596: 					node => $next_sib,
 1597: 					body => $next_sib->content,
 1598: 					pod => $pod,
 1599: 					type => 'modifier',
 1600: 					original_method => $method_name,
 1601: 					modifier => $modifier,
 1602: 				};
 1603: 				$self->_log("  Found method modifier: $full_name");
 1604: 			}
 1605: 		}
 1606: 	}
 1607: 
 1608: 	# Prevent silent duplicate method overwrites
 1609: 	my %seen;
 1610: 	@methods = grep {
 1611: 		my $n = $_->{name};
 1612: 		if ($seen{$n}++) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1613: 			$self->_log("  WARNING: duplicate method '$n' ignored");
 1614: 			0;
 1615: 		} else {
 1616: 			1;
 1617: 		}
 1618: 	} @methods;
 1619: 
 1620: 	return \@methods;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1621: }
 1622: 
 1623: # --------------------------------------------------
 1624: # _extract_class_methods
 1625: #
 1626: # Purpose:    Extract method declarations from
 1627: #             Perl 5.38 class { method {} } syntax
 1628: #             by regex-based scanning of the class
 1629: #             body content.
 1630: #
 1631: # Entry:      $content - full document source string.
 1632: #             $methods - arrayref to push discovered
 1633: #                        method hashrefs onto
 1634: #                        (modified in place).
 1635: #
 1636: # Exit:       Returns nothing. Appends to $methods.
 1637: #
 1638: # Side effects: Logs class and method discoveries
 1639: #               to stdout when verbose is set.
 1640: #
 1641: # Notes:      This is experimental — regex-based
 1642: #             class body parsing may misbehave on
 1643: #             complex or nested class declarations.
 1644: #             Class body boundaries are tracked by
 1645: #             simple brace counting, which will
 1646: #             fail on unbalanced braces in strings
 1647: #             or heredocs.
 1648: # --------------------------------------------------
 1649: sub _extract_class_methods {
●1650 → 1656 → 0 1650: 	my ($self, $content, $methods) = @_;
 1651: 
 1652: 	# EXPERIMENTAL: regex-based parsing, may misbehave on complex code
 1653: 
 1654: 	# Simple pattern: find "class Name {" blocks
 1655: 	# This won't handle all edge cases but will work for simple classes
 1656: 	while ($content =~ /class\s+(\w+)\s*\{/g) {
 1657: 		my $class_name = $1;
 1658: 		my $start_pos = pos($content);
 1659: 
 1660: 		# Find the matching closing brace. $start_pos is just after the
 1661: 		# opening '{' consumed by the regex above, so back up one
 1662: 		# character to hand the brace itself to extract_bracketed.
 1663: 		require Text::Balanced;
 1664: 		my $extracted = Text::Balanced::extract_bracketed(substr($content, $start_pos - 1), '{}');
 1665: 
 1666: 		next unless defined $extracted;	# unbalanced braces, skip class
 1667: 
 1668: 		my $class_body = substr($extracted, 1, length($extracted) - 2);
 1669: 
 1670: 		$self->_log("  Found class $class_name");
 1671: 
 1672: 		# Extract field declarations from class
 1673: 		my $fields = $self->_extract_field_declarations($class_body);
 1674: 
 1675: 		# Find methods in the class body
 1676: 		while ($class_body =~ /method\s+(\w+)\s*(\([^)]*\))?\s*\{/g) {
 1677: 			my ($method_name, $sig_with_parens) = ($1, $2 || '()');
 1678: 
 1679: 			# Skip private unless configured
 1680: 			if ($method_name =~ /^_/ && $method_name !~ /^_(new|init|build)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1681: 				next unless $self->{include_private};
 1682: 			}
 1683: 
 1684: 			# Reconstruct as sub for analysis
 1685: 			my $signature = $sig_with_parens;
 1686: 			$signature =~ s/^\(//;
 1687: 			$signature =~ s/\)$//;
 1688: 
 1689: 			# Build a fake sub declaration
 1690: 			my $fake_sub = "sub $method_name($signature) { }";
 1691: 
 1692: 			push @$methods, {
 1693: 				name => $method_name,
 1694: 				node => undef,
 1695: 				body => $fake_sub,	# Just the signature for now
 1696: 				is_stub => 1,
 1697: 				pod => '',
 1698: 				type => 'method',
 1699: 				class => $class_name,
 1700: 				fields => $fields,
 1701: 			};
 1702: 
 1703: 			$self->_log("  Found method $method_name in class $class_name");
 1704: 		}
 1705: 	}
 1706: }
 1707: 
 1708: # --------------------------------------------------
 1709: # _extract_pod_before
 1710: #
 1711: # Purpose:    Collect the POD documentation that
 1712: #             appears immediately before a
 1713: #             subroutine in the PPI document, by
 1714: #             walking backwards through siblings.
 1715: #
 1716: # Entry:      $sub - a PPI node (typically a
 1717: #                    PPI::Statement::Sub).
 1718: #
 1719: # Exit:       Returns a string containing all POD
 1720: #             content found before the sub, with
 1721: #             inline parameter comments converted
 1722: #             to =item format. Returns an empty
 1723: #             string if no POD is found.
 1724: #
 1725: # Side effects: None.
 1726: #
 1727: # Notes:      Stops walking backwards on the first
 1728: #             non-POD, non-whitespace, non-separator,
 1729: #             non-include node encountered.
 1730: #             Walking is capped at $POD_WALK_LIMIT
 1731: #             steps to prevent runaway processing
 1732: #             on pathological documents.
 1733: # --------------------------------------------------
 1734: sub _extract_pod_before {
●1735 → 1745 → 1767 1735: 	my ($self, $sub) = @_;
 1736: 
 1737: 	my $pod = '';
 1738: 	my $current = $sub->previous_sibling();
 1739: 	my $seen_code = 0;
 1740: 	my $steps = 0;
 1741: 
 1742: 	# Walk backwards collecting POD.
 1743: 	# Stop after the first pod token so that a =cut before =head1 METHODS
 1744: 	# prevents class-level POD from being mistaken for method-specific POD.
 1745: 	while($current && $steps++ < $POD_WALK_LIMIT) {

  Mutants (Total: 3, Killed: 3, Survived: 0)
 1746: 		if ($current->isa('PPI::Token::Pod')) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1747: 			$pod = $current->content() . $pod;
 1748: 			last;	# Only take the immediately adjacent pod block
 1749: 		} elsif ($current->isa('PPI::Token::Comment')) {
 1750: 			# Include comments that might contain parameter info
 1751: 			my $comment = $current->content();
 1752: 			if ($comment =~ /#\s*(?:param|arg|input)\s+\$(\w+)\s*:\s*(.+)/i) {

					

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

 1753: 				$pod .= "=item \$$1\n$2\n\n";
 1754: 			}
 1755: 		} elsif ($current->isa('PPI::Token::Whitespace') ||
 1756: 			 $current->isa('PPI::Token::Separator')) {
 1757: 			# Skip whitespace and separators
 1758: 		} elsif ($current->isa('PPI::Statement::Include')) {
 1759: 			# allow 'use strict', 'use warnings' between POD and sub
 1760: 		} else {
 1761: 			# Hit non-POD, non-whitespace - stop
 1762: 			last;
 1763: 		}
 1764: 		$current = $current->previous_sibling();
 1765: 	}
 1766: 
 1767: 	return $pod;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1768: }
 1769: 
 1770: # --------------------------------------------------
 1771: # _analyze_method
 1772: #
 1773: # Purpose:    Perform full multi-source analysis of
 1774: #             a single method and produce a complete
 1775: #             schema hashref, combining POD analysis,
 1776: #             code pattern detection, signature
 1777: #             analysis, validator schema extraction,
 1778: #             confidence scoring, relationship
 1779: #             detection, and modern Perl feature
 1780: #             extraction.
 1781: #
 1782: # Entry:      $method - a method hashref as produced
 1783: #                       by _find_methods, containing
 1784: #                       at minimum: name, body, pod.
 1785: #
 1786: # Exit:       Returns a schema hashref containing:
 1787: #             function, input, output, _confidence,
 1788: #             _analysis, _notes, and optionally:
 1789: #             new, accessor, relationships,
 1790: #             _yamltest_hints, _attributes,
 1791: #             _modern_features, _fields, _model,
 1792: #             _low_confidence.
 1793: #
 1794: # Side effects: Logs progress to stdout when verbose
 1795: #               is set. May carp or croak if
 1796: #               strict_pod is enabled and POD/code
 1797: #               disagreements are found.
 1798: #
 1799: # Notes:      This is the central analysis entry
 1800: #             point — it orchestrates all other
 1801: #             analysis helpers and merges their
 1802: #             results. The non-invasive reasoning
 1803: #             layer (Model::Method, Analyzer::*)
 1804: #             runs after the main schema is built
 1805: #             and attaches metadata only.
 1806: # --------------------------------------------------
 1807: sub _analyze_method {
●1808 → 1818 → 1822 1808: 	my ($self, $method) = @_;
 1809: 	my $code = $method->{body};
 1810: 	my $pod = $method->{pod};
 1811: 
 1812: 	# Extract modern features
 1813: 	my $attributes = $self->_extract_subroutine_attributes($code);
 1814: 	my $postfix_derefs = $self->_analyze_postfix_dereferencing($code);
 1815: 	my $fields = $self->_extract_field_declarations($code);
 1816: 
 1817: 	# If this method came from a class, use those field declarations
 1818: 	if ($method->{fields} && keys %{$method->{fields}}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1819: 		$fields = $method->{fields};
 1820: 	}
 1821: 
●1822 → 1841 → 1871 1822: 	my $schema = {
 1823: 		function => $method->{name},
 1824: 		_confidence => {
 1825: 			'input' => {},
 1826: 			'output' => {}
 1827: 		},
 1828: 		input => {},
 1829: 		output => {},
 1830: 		setup => undef,
 1831: 		transforms => {},
 1832: 	};
 1833: 
 1834: 	# Analyze different sources
 1835: 	my $pod_params = $self->_analyze_pod($pod);
 1836: 	my $code_params = $self->_analyze_code($code, $method);
 1837: 
 1838: 	# Validate POD/code agreement if strict mode is enabled.
 1839: 	# Skip when there is no POD at all — strict_pod checks accuracy of
 1840: 	# existing documentation, not whether every method is documented.
 1841: 	if ($self->{strict_pod} && $pod) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1842: 		my @validation_errors = $self->_validate_pod_code_agreement(
 1843: 			$pod_params,
 1844: 			$code_params,
 1845: 			$method->{name},
 1846: 			{
 1847: 				ignore_self => 1,
 1848: 				allow_renames => 1,
 1849: 			}
 1850: 		);
 1851: 
 1852: 		if (@validation_errors) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1853: 			my $error_msg = "POD/Code disagreement in method '$method->{name}':\n  " .
 1854: 				join("\n  ", @validation_errors);
 1855: 
 1856: 			# Add to schema for reference even if we croak
 1857: 			$schema->{_pod_validation_errors} = \@validation_errors;
 1858: 
 1859: 			# Either croak immediately or log based on configuration
 1860: 			if($self->{strict_pod} == 2) {	# 2 = fatal errors

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1861: 				croak("[POD STRICT] $error_msg");
 1862: 			} else {	# 1 = warnings
 1863: 				carp("[POD STRICT] $error_msg");
 1864: 				# Continue with analysis, but mark as problematic
 1865: 				$schema->{_pod_disagreement} = 1;
 1866: 			}
 1867: 		}
 1868: 		$schema->{_strict_pod_level} = $self->{strict_pod};
 1869: 	}
 1870: 
●1871 → 1873 → 1897 1871: 	my $validator_params = $self->_extract_validator_schema($code);
 1872: 
 1873: 	if ($validator_params) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1874: 		$schema->{input} = $validator_params->{input};
 1875: 		$schema->{input_style} = 'hash';
 1876: 		$schema->{_confidence}{input} = { 'factors' => [ 'Determined from validator' ], 'level' => 'high' };
 1877: 		$schema->{_analysis}{confidence_factors}{input} = [
 1878: 			'Input schema extracted from validator'
 1879: 		];
 1880: 	} else {
 1881: 		# Merge field declarations into code_params before merging analyses
 1882: 		if (keys %$fields) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1883: 			$self->_merge_field_declarations($code_params, $fields);
 1884: 		}
 1885: 
 1886: 		# Merge analyses
 1887: 		$schema->{input} = $self->_merge_parameter_analyses(
 1888: 			$pod_params,
 1889: 			$code_params,
 1890: 		);
 1891: 	}
 1892: 
 1893: # ----------------------------------------
 1894: # Legacy Output Analysis (unchanged)
 1895: # ----------------------------------------
 1896: 
●1897 → 1910 → 1916 1897: $schema->{output} = $self->_analyze_output(
 1898:     $method->{pod},
 1899:     $method->{body},
 1900:     $method->{name}
 1901: );
 1902: 
 1903: 
 1904: 	# Detect accessor methods
 1905: 	$self->_detect_accessor_methods($method, $schema);
 1906: 
 1907: 	# Detect if this is an instance method that needs object instantiation
 1908: 	# Constructors never require object instantiation
 1909: 	my $needs_object = $self->_needs_object_instantiation($method->{name}, $method->{body}, $method);
 1910: 	if($method->{name} ne 'new' && $needs_object) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1911: 		$schema->{new} = $needs_object;
 1912: 		$self->_log("  NEW: Method requires object instantiation: $needs_object");
 1913: 	}
 1914: 
 1915: 	# Calculate confidences
●1916 → 1917 → 1920 1916: 	my $input_confidence = $schema->{_confidence}{'input'};
 1917: 	if(!ref($input_confidence)) {

					

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

 1918: 		$input_confidence = $schema->{_confidence}{'input'} = $self->_calculate_input_confidence($schema->{input});
 1919: 	}
●1920 → 1933 → 1938 1920: 	my $output_confidence = $schema->{_confidence}{'output'} = $self->_calculate_output_confidence($schema->{output});
 1921: 
 1922: 	# Add metadata
 1923: 	$schema->{_notes} = $self->_generate_notes($schema->{input});
 1924: 
 1925: 	# Add analytics
 1926: 	$schema->{_analysis} ||= {};
 1927: 	$schema->{_analysis}{input_confidence} = $input_confidence->{level};
 1928: 	$schema->{_analysis}{output_confidence} = $output_confidence->{level};
 1929: 	$schema->{_analysis}{confidence_factors} ||= {};
 1930: 	$schema->{_analysis}{confidence_factors}{input} ||= $input_confidence->{factors};
 1931: 	$schema->{_analysis}{confidence_factors}{output} ||= $output_confidence->{factors};
 1932: 
 1933: 	foreach my $mode('input', 'output') {
 1934: 		$self->_set_defaults($schema, $mode);
 1935: 	}
 1936: 
 1937: 	# Optionally store detailed per-parameter analysis
●1938 → 1938 → 1943 1938: 	if ($input_confidence->{per_parameter}) {

					

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

 1939: 		$schema->{_analysis}{per_parameter_scores} = $input_confidence->{per_parameter};
 1940: 	}
 1941: 
 1942: 	# Calculate overall confidence (for backward compatibility)
●1943 → 1963 → 1969 1943: 	my $input_level = $input_confidence->{level};
 1944: 	my $output_level = $output_confidence->{level};
 1945: 
 1946: 	my %level_rank = (
 1947: 		none => 0,
 1948: 		very_low => 1,
 1949: 		low => 2,
 1950: 		medium => 3,
 1951: 		high => 4
 1952: 	);
 1953: 
 1954: 	# Overall is the lower of input and output
 1955: 	$input_level //= 'none';
 1956: 	$output_level //= 'none';
 1957: 	my $overall = $level_rank{$input_level} < $level_rank{$output_level} ? $input_level : $output_level;

					

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

 1958: 
 1959: 	$schema->{_analysis}{overall_confidence} = $overall;
 1960: 
 1961: 	# Analyze parameter relationships
 1962: 	my $relationships = $self->_analyze_relationships($method);
 1963: 	if ($relationships && @{$relationships}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1964: 		$schema->{relationships} = $relationships;
 1965: 		$self->_log("  Found " . scalar(@$relationships) . " parameter relationships");
 1966: 	}
 1967: 
 1968: 	# Store modern feature info in schema
●1969 → 1974 → 1978 1969: 	$schema->{_attributes} = $attributes if keys %$attributes;
 1970: 	$schema->{_modern_features}{postfix_dereferencing} = $postfix_derefs if keys %$postfix_derefs;
 1971: 	$schema->{_fields} = $fields if keys %$fields;
 1972: 
 1973: 	# Store class info if this is a class method
 1974: 	if ($method->{class}) {

					

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

 1975: 		$schema->{_class} = $method->{class};
 1976: 	}
 1977: 
●1978 → 1981 → 1992 1978: 	my $hints = $self->_extract_test_hints($method, $schema);
 1979: 	$self->_extract_pod_examples($pod, $hints);
 1980: 
 1981: 	for my $k (qw(boundary_values invalid_inputs valid_inputs equivalence_classes)) {
 1982: 		my %seen;
 1983: 		$hints->{$k} = [
 1984: 			grep { !$seen{ defined $_ ? $_ : '__undef__' }++ }
 1985: 			@{ $hints->{$k} }
 1986: 		];
 1987: 	}
 1988: 
 1989: 	# --------------------------------------------------
 1990: 	# YAML test hints: numeric boundaries
 1991: 	# --------------------------------------------------
●1992 → 1992 → 2009 1992: 	if ($self->_method_has_numeric_intent($schema)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1993: 		$schema->{_yamltest_hints} ||= {};
 1994: 
 1995: 		# Do not override existing hints
 1996: 		$schema->{_yamltest_hints}{boundary_values} ||= [];
 1997: 
 1998: 		my %seen = map { (defined $_ ? $_ : '__undef__') => 1 }
 1999: 			@{ $schema->{_yamltest_hints}{boundary_values} };
 2000: 
 2001: 		foreach my $v (@{ $self->_numeric_boundary_values }) {
 2002: 			my $key = defined $v ? $v : '__undef__';
 2003: 			push @{ $schema->{_yamltest_hints}{boundary_values} }, $v unless $seen{$key}++;
 2004: 		}
 2005: 
 2006: 		$self->_log('  HINTS: Added numeric boundary values');
 2007: 	}
 2008: 
●2009 → 2009 → 2017 2009: 	if (keys %$hints) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2010: 		$schema->{_yamltest_hints} ||= {};
 2011: 		foreach my $k (keys %$hints) {
 2012: 			$schema->{_yamltest_hints}{$k} = $hints->{$k}
 2013: 			unless exists $schema->{_yamltest_hints}{$k};
 2014: 		}
 2015: 	}
 2016: 
●2017 → 2017 → 2026 2017: 	if(($level_rank{$overall} < $level_rank{$LEVEL_MEDIUM}) &&

					

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

 2018: 	   ($level_rank{$overall} < ($self->{confidence_threshold} * 4))) {

					

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

 2019: 		$schema->{_low_confidence} = 1
 2020: 	}
 2021: 
 2022: 	# ----------------------------------------
 2023: 	# Non-invasive reasoning layer
 2024: 	# ----------------------------------------
 2025: 
●2026 → 2035 → 2039 2026: 	my $method_model = App::Test::Generator::Model::Method->new(
 2027: 		name => $method->{name},
 2028: 		source => $method->{body},
 2029: 	);
 2030: 
 2031: 	my $return_analyzer = App::Test::Generator::Analyzer::Return->new();
 2032: 	$return_analyzer->analyze($method_model);
 2033: 
 2034: 	# Let model learn from finalized schema
 2035: 	if ($schema->{output}) {

					

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

 2036: 		$method_model->absorb_legacy_output($schema->{output});
 2037: 	}
 2038: 
 2039: 	$method_model->resolve_return_type();
 2040: 	$method_model->resolve_classification();
 2041: 	$method_model->resolve_confidence();
 2042: 
 2043: 	# Attach only metadata
 2044: 	$schema->{_model} = {
 2045: 		classification => $method_model->classification,
 2046: 		confidence => $method_model->confidence,
 2047: 	};
 2048: 
 2049: 	# ----------------------------------------
 2050: 	# Return Meta Analysis (Non-invasive)
 2051: 	# ----------------------------------------
 2052: 
 2053: 	my $meta = App::Test::Generator::Analyzer::ReturnMeta->new();
 2054: 	my $analysis = $meta->analyze($schema);
 2055: 
 2056: 	$schema->{_analysis}{stability_score} = $analysis->{stability_score};
 2057: 	$schema->{_analysis}{consistency_score} = $analysis->{consistency_score};
 2058: 	$schema->{_analysis}{risk_flags} = $analysis->{risk_flags};
 2059: 
 2060: 	# ----------------------------------------
 2061: 	# Side Effect Analysis (Non-invasive)
 2062: 	# ----------------------------------------
 2063: 
 2064: 	my $se = App::Test::Generator::Analyzer::SideEffect->new();
 2065: 
 2066: 	my $effects = $se->analyze($method);
 2067: 
 2068: 	$schema->{_analysis}{side_effects} = $effects;
 2069: 
 2070: 	# ----------------------------------------
 2071: 	# Complexity Analysis (Non-invasive)
 2072: 	# ----------------------------------------
 2073: 
 2074: 	my $cx = App::Test::Generator::Analyzer::Complexity->new();
 2075: 	my $complexity = $cx->analyze($method);
 2076: 
 2077: 	$schema->{_analysis}{complexity} = $complexity;
 2078: 
 2079: 	return $schema;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2080: }
 2081: 
 2082: # --------------------------------------------------
 2083: # _method_has_numeric_intent
 2084: #
 2085: # Purpose:    Determine whether a method schema
 2086: #             has numeric intent — either a numeric
 2087: #             output type or at least one required
 2088: #             numeric input parameter — to decide
 2089: #             whether to add standard numeric
 2090: #             boundary hint values.
 2091: #
 2092: # Entry:      $schema - schema hashref as built by
 2093: #                       _analyze_method.
 2094: #
 2095: # Exit:       Returns 1 if numeric intent is
 2096: #             detected, 0 otherwise.
 2097: #
 2098: # Side effects: None.
 2099: # --------------------------------------------------
 2100: sub _method_has_numeric_intent {
●2101 → 2107 → 2112 2101: 	my ($self, $schema) = @_;
 2102: 
 2103: 	# Numeric output
 2104: 	return 1 if ($schema->{output} && $schema->{output}{type} && $schema->{output}{type} =~ /^(number|integer)$/);

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2105: 
 2106: 	# Numeric inputs
 2107: 	foreach my $p (values %{ $schema->{input} || {} }) {
 2108: 		next if $p->{optional};
 2109: 		return 1 if ($p->{type} && $p->{type} =~ /^(number|integer)$/);

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2110: 	}
 2111: 
 2112: 	return 0;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2113: }
 2114: 
 2115: # --------------------------------------------------
 2116: # _numeric_boundary_values
 2117: #
 2118: # Purpose:    Return the standard set of numeric
 2119: #             boundary values used as test hints
 2120: #             for methods with numeric intent.
 2121: #
 2122: # Entry:      None.
 2123: #
 2124: # Exit:       Returns an arrayref of boundary
 2125: #             values: [-1, 0, 1, 2, 100].
 2126: #
 2127: # Side effects: None.
 2128: # --------------------------------------------------
 2129: sub _numeric_boundary_values {
 2130: 	return [ -1, 0, 1, 2, 100 ];
 2131: }
 2132: 
 2133: # --------------------------------------------------
 2134: # _detect_accessor_methods
 2135: #
 2136: # Purpose:    Detect whether a method is a getter,
 2137: #             setter, or combined getter/setter
 2138: #             accessor by analysing assignment and
 2139: #             return patterns involving $self->{...}.
 2140: #
 2141: # Entry:      $method - method hashref containing
 2142: #                       at minimum 'body' and
 2143: #                       optionally 'pod'.
 2144: #             $schema - schema hashref (modified
 2145: #                       in place).
 2146: #
 2147: # Exit:       Returns nothing. Modifies $schema in
 2148: #             place, setting accessor, input,
 2149: #             input_style, output, and _confidence
 2150: #             keys as appropriate.
 2151: #
 2152: # Side effects: Croaks if a getter/setter has more
 2153: #               than one argument, or if a setter
 2154: #               returns non-self data.
 2155: #               Logs detections to stdout when
 2156: #               verbose is set.
 2157: #
 2158: # Notes:      Four accessor patterns are detected
 2159: #             in order: (1) combined getter/setter
 2160: #             with shift, (2) combined getter/setter
 2161: #             with validated input, (3) getter only,
 2162: #             (4) setter that returns $self. Methods
 2163: #             accessing multiple $self fields are
 2164: #             skipped immediately.
 2165: # --------------------------------------------------
 2166: sub _detect_accessor_methods {
●2167 → 2177 → 2180 2167: 	my ($self, $method, $schema) = @_;
 2168: 
 2169: 	my $body = $method->{body};
 2170: 
 2171: 	# Normalize whitespace for regex sanity
 2172: 	my $code = $body;
 2173: 	$code =~ s/\s+/ /g;
 2174: 
 2175: 	# If a method touches more than one $self->{...}, it’s not an accessor.
 2176: 	my %fields_seen;
 2177: 	while ($code =~ /\$self\s*->\s*\{\s*['"]?([^}'"]+)['"]?\s*\}/g) {
 2178: 		$fields_seen{$1}++;
 2179: 	}
●2180 → 2180 → 2188 2180: 	if (keys(%fields_seen) > 1) {

					

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

 2181: 		$self->_log("  Skipping accessor detection: multiple fields accessed");
 2182: 		return;
 2183: 	}
 2184: 
 2185: 	# -------------------------------
 2186: 	# Getter/Setter combo
 2187: 	# -------------------------------
●2188 → 2188 → 2384 2188: 	if (

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2189: 		# Require get/set of the same property
 2190: 		$code =~ /\$self\s*->\s*\{\s*['"]?([^}'"]+)['"]?\s*\}\s*=\s*shift\s*;/ &&
 2191: 		$code =~ /return\s+\$self\s*->\s*\{\s*['"]?\Q$1\E['"]?\s*\}\s*;/ &&
 2192: 		$code =~ /if\s*\(\s*\@_/
 2193: 	) {
 2194: 		my $property = $1;
 2195: 
 2196: 		if(!defined($property)) {

					

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

 2197: 			if($code =~ /\$self\s*->\s*\{\s*['"]?([^}'"]+)['"]?\s*\}\s*=\s*shift\s*;/) {

					

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

 2198: 				$property = $1;
 2199: 			}
 2200: 		}
 2201: 
 2202: 		$schema->{accessor} = {
 2203: 			type => 'getset',
 2204: 			property => $property,
 2205: 		};
 2206: 
 2207: 		$self->_log("  Detected getter/setter accessor for property: $property");
 2208: 
 2209: 		$schema->{input} ||= { value => { type => 'string', optional => 1 } };
 2210: 
 2211: 		$schema->{input_style} = 'hash';
 2212: 
 2213: 		$schema->{_confidence}{input} = {
 2214: 			level => 'high',
 2215: 			factors => ['Detected combined getter/setter accessor'],
 2216: 		};
 2217: 		if (my $pod = $method->{pod}) {

					

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

 2218: 			if ($pod =~ /\b(LWP::UserAgent(::\w+)*)\b/) {

					

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

 2219: 				my $class = $1;
 2220: 				$schema->{output} = {
 2221: 					type => 'object',
 2222: 					isa => $class,
 2223: 				};
 2224: 				$schema->{input}{$property} = {
 2225: 					type => 'object',
 2226: 					isa => $class,
 2227: 					optional => 1,
 2228: 				};
 2229: 
 2230: 				$schema->{_confidence}{output} = {
 2231: 					level => 'high',
 2232: 					factors => ['POD specifies UserAgent object'],
 2233: 				};
 2234: 			}
 2235: 		}
 2236: 	} elsif($code =~ /if\s*\(\s*(?:\@_|[\$]\w+)/ &&
 2237: 	    $code =~ /\$self\s*->\s*\{\s*['"]?([^}'"]+)['"]?\s*\}\s*=\s*(?:shift|\@_|\$_\[\d+\]|\$\w+)\b/x &&
 2238: 	    $code =~ /return\b/
 2239: 	) {
 2240: 		# -------------------------------
 2241: 		# Getter/Setter (validated input)
 2242: 		# -------------------------------
 2243: 		my $property = $1;
 2244: 
 2245: 		if(!defined($property)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2246: 			if($code =~ /\$self\s*->\s*\{\s*['"]?([^}'"]+)['"]?\s*\}\s*=/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2247: 				$property = $1;
 2248: 			}
 2249: 		}
 2250: 		if ($code =~ /validate_strict/) {

					

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

 2251: 			push @{ $schema->{_confidence}{input}{factors} }, 'Setter uses Params::Validate::Strict';
 2252: 		} else {
 2253: 			# ---------------------------------------
 2254: 			# Detect object input via blessed($arg)
 2255: 			# ---------------------------------------
 2256: 			if ($code =~ /blessed\s*\(\s*\$(\w+)\s*\)/) {

					

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

 2257: 				my $param = $1;
 2258: 
 2259: 				$self->_log("  Detected object input via blessed(\$$param)");
 2260: 
 2261: 				$schema->{input} = {
 2262: 					$param => {
 2263: 						type => 'object',
 2264: 						optional => 1,
 2265: 					}
 2266: 				};
 2267: 
 2268: 				$schema->{_confidence}{input} = {
 2269: 					level   => 'high',
 2270: 					factors => ['Input validated by Scalar::Util::blessed'],
 2271: 				};
 2272: 			} else {
 2273: 				# fallback ONLY if nothing known
 2274: 				$schema->{input} ||= {
 2275: 					value => { type => 'string', optional => 1 },
 2276: 				};
 2277: 			}
 2278: 		};
 2279: 		$schema->{accessor} = {
 2280: 			type => 'getset',
 2281: 			property => $property,
 2282: 		};
 2283: 
 2284: 		$self->_log("  Detected getter/setter accessor for property: $property");
 2285: 		if (my $pod = $method->{pod}) {

					

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

 2286: 			if ($pod =~ /\b(LWP::UserAgent(::\w+)*)\b/) {

					

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

 2287: 				my $class = $1;
 2288: 				$schema->{output} = {
 2289: 					type => 'object',
 2290: 					isa => $class,
 2291: 				};
 2292: 				$schema->{input}{$property} = {
 2293: 					type => 'object',
 2294: 					isa => $class,
 2295: 					optional => 1,
 2296: 				};
 2297: 
 2298: 				$schema->{_confidence}{output} = {
 2299: 					level => 'high',
 2300: 					factors => ['POD specifies UserAgent object'],
 2301: 				};
 2302: 			}
 2303: 		}
 2304: 		if(ref($schema->{input}) eq 'HASH') {

					

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

 2305: 			if(scalar keys(%{$schema->{input}}) > 1) {

					

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

 2306: 				croak(__PACKAGE__, ': A getset accessor function can have at most one argument');
 2307: 			}
 2308: 		}
 2309: 		$schema->{input}->{$property}->{position} = 0;
 2310: 	} elsif ($code =~ /return\s+\$self\s*->\s*\{\s*['"]?([^}'"]+)['"]?\s*\}\s*;/) {
 2311: 		# -------------------------------
 2312: 		# Getter
 2313: 		# -------------------------------
 2314: 		my $property = $1;
 2315: 
 2316: 		# Don't flag mutators like
 2317: 		# sub foo {
 2318: 		    # my $self = shift;
 2319: 		    # $self->{bar} = shift;
 2320: 		    # return $self->{bar};
 2321: 		# }
 2322: 		# Only exclude if the property is being set FROM EXTERNAL INPUT
 2323: 		if($code !~ /\$self\s*->\s*\{\s*['"]?\Q$property\E['"]?\s*\}\s*=\s*(?:shift|\$\w+\s*=\s*shift|\@_|\$_\[\d+\])/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2324: 			my @returns = $code =~ /return\b/g;
 2325: 			my @self_returns = $code =~ /return\s+\$self\s*->\s*\{\s*['"]?\Q$property\E['"]?\s*\}/g;
 2326: 			# it's a getter
 2327: 			if (scalar(@returns) == scalar(@self_returns)) {

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2328: 				# all returns are returning $self->{$property}, so it's a getter
 2329: 				$schema->{accessor} = {
 2330: 					type => 'getter',
 2331: 					property => $property,
 2332: 				};
 2333: 
 2334: 				$self->_log("  Detected getter accessor for property: $property");
 2335: 
 2336: 				$schema->{_confidence}{output} = {
 2337: 					level => 'high',
 2338: 					factors => ['Detected getter method'],
 2339: 				};
 2340: 				delete $schema->{input};
 2341: 			}
 2342: 		}
 2343: 	} elsif (
 2344: 		$code =~ /return\s+\$self\b/ &&
 2345: 		$code =~ /\$self\s*->\s*\{\s*['"]?([^}'"]+)['"]?\s*\}\s*=\s*\$(\w+)\s*;/
 2346: 	) {
 2347: 		# -------------------------------
 2348: 		# Setter
 2349: 		# -------------------------------
 2350: 		my ($property, $param) = ($1, $2);
 2351: 
 2352: 		$schema->{accessor} = {
 2353: 			type => 'setter',
 2354: 			property => $property,
 2355: 			param => $param,
 2356: 		};
 2357: 
 2358: 		$self->_log("  Detected setter accessor for property: $property");
 2359: 
 2360: 		$schema->{input} = {
 2361: 			$param => { type => 'string' }, # safe default
 2362: 		};
 2363: 		$schema->{input_style} = 'hash';
 2364: 
 2365: 		$schema->{_confidence}{input} = {
 2366: 			level => 'high',
 2367: 			factors => ['Detected setter/accessor method'],
 2368: 		};
 2369: 		if($schema->{output}{_returns_self}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2370: 			if($schema->{output}{type} ne 'object') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2371: 				croak 'Setter can not return data other than $self';
 2372: 			}
 2373: 			if($schema->{output}{isa} ne $self->{_package_name}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2374: 				croak 'Setter can not return data other than $self';
 2375: 			}
 2376: 		} elsif(scalar(keys %{$schema->{output}}) != 0) {

					

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

 2377: 			$self->_analysis_error(
 2378: 				method  => $method->{name},
 2379: 				message => "Setter cannot return data",
 2380: 			);
 2381: 		}
 2382: 	}
 2383: 
●2384 → 2384 → 0 2384: 	if(exists($schema->{accessor})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2385: 		if($schema->{accessor}{type} && $schema->{accessor}{type} =~ /setter|getset/ && $schema->{input}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2386: 			for my $param (keys %{ $schema->{input} }) {
 2387: 				my $in = $schema->{input}{$param};
 2388: 
 2389: 				if ($in->{type} && ($in->{type} eq 'object')) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2390: 					$schema->{output} = {
 2391: 						type => 'object',
 2392: 						($in->{isa} ? (isa => $in->{isa}) : ()),
 2393: 					};
 2394: 
 2395: 					$schema->{_confidence}{output} = {
 2396: 						level => 'high',
 2397: 						factors => ['Output type propagated from setter input'],
 2398: 					};
 2399: 				}
 2400: 			}
 2401: 		}
 2402: 
 2403: 		if($schema->{accessor}{type} && $schema->{accessor}{property} && ($schema->{accessor}{type} =~ /getter|getset/) &&

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2404: 		   ((!defined($schema->{output}{type})) || ($schema->{output}{type} eq 'string'))) {
 2405: 			if (my $pod = $method->{pod}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2406: 				# POD says "UserAgent object"
 2407: 				if ($pod =~ /\bUser[- ]?Agent\b.*\bobject\b/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2408: 					$schema->{output}{type} = 'object';
 2409: 					$schema->{output}{isa} = 'LWP::UserAgent';
 2410: 
 2411: 					push @{ $schema->{_confidence}{output}{factors} }, 'POD indicates UserAgent object';
 2412: 
 2413: 					$schema->{_confidence}{output}{level} = 'high';
 2414: 				}
 2415: 			}
 2416: 		}
 2417: 	}
 2418: }
 2419: 
 2420: # --------------------------------------------------
 2421: # _analysis_error
 2422: #
 2423: # Purpose:    Report a fatal analysis error with
 2424: #             module, method, and file context,
 2425: #             then croak.
 2426: #
 2427: # Entry:      Named args:
 2428: #               method  - method name string.
 2429: #               message - error description string.
 2430: #
 2431: # Exit:       Does not return — always croaks.
 2432: #
 2433: # Side effects: None beyond the croak.
 2434: # --------------------------------------------------
 2435: sub _analysis_error {
 2436: 	my ($self, %args) = @_;
 2437: 
 2438: 	my $method = $args{method} // 'UNKNOWN';
 2439: 	my $msg = $args{message} // 'Analysis error';
 2440: 
 2441: 	my $module = $self->{_package_name} // 'UNKNOWN';
 2442: 	my $file   = $self->{input_file} // 'UNKNOWN';
 2443: 
 2444: 	croak join "\n",
 2445: 		$msg,
 2446: 		"  Module: $module",
 2447: 		"  Method: $method",
 2448: 		"  File:   $file",
 2449: 	'';
 2450: }
 2451: 
 2452: # --------------------------------------------------
 2453: # _extract_validator_schema
 2454: #
 2455: # Purpose:    Try each supported validator extractor
 2456: #             in priority order and return the first
 2457: #             schema that yields a non-empty input
 2458: #             spec. Used to detect explicit
 2459: #             parameter validation declarations
 2460: #             before falling back to heuristic
 2461: #             code analysis.
 2462: #
 2463: # Entry:      $code - method body source string.
 2464: #
 2465: # Exit:       Returns a schema hashref on success,
 2466: #             or undef if no supported validator
 2467: #             call is detected.
 2468: #
 2469: # Side effects: None.
 2470: #
 2471: # Notes:      Extractors tried in order:
 2472: #             Params::Validate::Strict,
 2473: #             Params::Validate,
 2474: #             MooseX::Params::Validate,
 2475: #             Type::Params.
 2476: # --------------------------------------------------
 2477: sub _extract_validator_schema {
●2478 → 2480 → 2485 2478: 	my ($self, $code) = @_;
 2479: 
 2480: 	for my $extractor ('_extract_pvs_schema', '_extract_pv_schema', '_extract_moosex_params_schema', '_extract_type_params_schema') {
 2481: 		my $res = $self->$extractor($code);
 2482: 		return $res if ($res && ref($res) eq 'HASH' && keys %{ $res->{input} || {} });

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2483: 	}
 2484: 
 2485: 	return;
 2486: }
 2487: 
 2488: # --------------------------------------------------
 2489: # _parse_schema_hash
 2490: #
 2491: # Purpose:    Parse a PPI block node representing
 2492: #             a validator schema hash literal and
 2493: #             return a normalised schema structure
 2494: #             suitable for use as input spec.
 2495: #
 2496: # Entry:      $hash - a PPI node with a children()
 2497: #                     method, typically a
 2498: #                     PPI::Structure::Block from
 2499: #                     a validate_strict call.
 2500: #
 2501: # Exit:       Returns a hashref with keys:
 2502: #               input       - hashref of param specs
 2503: #               input_style - 'hash'
 2504: #               _confidence - confidence hashref
 2505: #             or undef if parsing fails.
 2506: #
 2507: # Side effects: None.
 2508: # --------------------------------------------------
 2509: sub _parse_schema_hash {
●2510 → 2514 → 2569 2510: 	my ($self, $hash) = @_;
 2511: 
 2512: 	my %result;
 2513: 
 2514: 	for my $child ($hash->children) {
 2515: 		# skip whitespace and operators
 2516: 		if ($child->isa('PPI::Statement') || $child->isa('PPI::Statement::Expression')) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2517: 			my ($key, $val);
 2518: 
 2519: 			my @tokens = grep {
 2520: 				!$_->isa('PPI::Token::Whitespace') &&
 2521: 				!$_->isa('PPI::Token::Operator')
 2522: 			} $child->children;
 2523: 
 2524: 			for (my $i = 0; $i < @tokens - 1; $i++) {

					

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

 2525: 				if(($tokens[$i]->isa('PPI::Token::Word') || $tokens[$i]->isa('PPI::Token::Quote')) &&

					

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

 2526: 				   $tokens[$i+1]->isa('PPI::Structure::Constructor')) {
 2527: 					$key = $tokens[$i]->content;
 2528: 					$key =~ s/^['"]|['"]$//g;
 2529: 					$val = $tokens[$i+1];
 2530: 					last;
 2531: 				}
 2532: 			}
 2533: 
 2534: 			next unless $key && $val;
 2535: 
 2536: 			my %param;
 2537: 			for my $inner ($val->children) {
 2538: 				next unless $inner->isa('PPI::Statement') || $inner->isa('PPI::Statement::Expression');
 2539: 
 2540: 				my ($k, undef, $v) = grep {
 2541: 					!$_->isa('PPI::Token::Whitespace') &&
 2542: 					!$_->isa('PPI::Token::Operator')
 2543: 				} $inner->children;
 2544: 
 2545: 				next unless $k && $v;
 2546: 
 2547: 				my $keyname = $k->content;
 2548: 				my $value = $v->can('content') ? $v->content : undef;
 2549: 				$value =~ s/^['"]|['"]$//g if defined $value;
 2550: 
 2551: 				if ($keyname eq 'type') {

					

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

 2552: 					$param{type} = lc($value);
 2553: 				} elsif ($keyname eq 'optional') {
 2554: 					$param{optional} = $value ? 1 : 0;
 2555: 				} elsif ($keyname =~ /^(min|max)$/ && looks_like_number($value)) {
 2556: 					$param{$keyname} = 0 + $value;
 2557: 				} elsif ($keyname eq 'matches') {
 2558: 					$param{matches} = qr/$value/;
 2559: 				}
 2560: 			}
 2561: 
 2562: 			$param{type} //= 'string';
 2563: 			$param{optional} //= 0;
 2564: 
 2565: 			$result{$key} = \%param;
 2566: 		}
 2567: 	}
 2568: 
 2569: 	return {
 2570: 		input => \%result,
 2571: 		input_style => 'hash',
 2572: 		_confidence => {
 2573: 			input => {
 2574: 				level => 'high',
 2575: 				factors => ['Input schema extracted from validator'],
 2576: 			},
 2577: 		},
 2578: 	};
 2579: }
 2580: 
 2581: # --------------------------------------------------
 2582: # _ppi
 2583: #
 2584: # Purpose:    Return a PPI::Document for a code
 2585: #             string, using a per-instance cache
 2586: #             to avoid re-parsing the same string
 2587: #             multiple times during a single
 2588: #             analysis pass.
 2589: #
 2590: # Entry:      $code - either a string of Perl source
 2591: #                     code, or an object that
 2592: #                     already has a find() method
 2593: #                     (returned as-is).
 2594: #
 2595: # Exit:       Returns a PPI::Document, or the
 2596: #             original object if it already
 2597: #             supports find().
 2598: #
 2599: # Side effects: Populates $self->{_ppi_cache}.
 2600: # --------------------------------------------------
 2601: sub _ppi {
 2602: 	my ($self, $code) = @_;
 2603: 
 2604: 	return $code if ref($code) && $code->can('find');

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2605: 
 2606: 	$self->{_ppi_cache} ||= {};
 2607: 	return $self->{_ppi_cache}{$code} //= PPI::Document->new(\$code);

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2608: }
 2609: 
 2610: # --------------------------------------------------
 2611: # _extract_pvs_schema
 2612: #
 2613: # Purpose:    Detect and extract a parameter schema
 2614: #             from a Params::Validate::Strict
 2615: #             validate_strict() call in the method
 2616: #             body.
 2617: #
 2618: # Entry:      $code - method body source string.
 2619: #
 2620: # Exit:       Returns a schema hashref with input,
 2621: #             style, and source keys on success,
 2622: #             or undef if no validate_strict call
 2623: #             is found or parsing fails.
 2624: #
 2625: # Side effects: None.
 2626: # --------------------------------------------------
 2627: sub _extract_pvs_schema {
●2628 → 2638 → 2672 2628: 	my ($self, $code) = @_;
 2629: 
 2630: 	return unless $code =~ /\bvalidate_strict\s*\(/;
 2631: 
 2632: 	my $doc = $self->_ppi($code) or return;
 2633: 
 2634: 	my $calls = $doc->find(sub {
 2635: 		$_[1]->isa('PPI::Token::Word') && ($_[1]->content eq 'validate_strict' || $_[1]->content eq 'Params::Validate::Strict::validate_strict')
 2636: 	}) or return;
 2637: 
 2638: 	for my $call (@$calls) {
 2639: 		my $list = $call->parent();
 2640: 		while ($list && !$list->isa('PPI::Structure::List')) {
 2641: 			$list = $list->parent();
 2642: 		}
 2643: 		if(!defined($list)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2644: 			my $next = $call->next_sibling();
 2645: 			next unless defined $next;
 2646: 			if($next->content() =~ /schema\s*=>\s*(\{(?:[^{}]|\{(?:[^{}]|\{[^{}]*\})*\})*\})/s) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2647: 				my $schema_text = $1;
 2648: 				my $compartment = Safe->new();
 2649: 				$compartment->permit_only(qw(:base_core :base_mem :base_orig));
 2650: 
 2651: 				my $schema_str = "my \$schema = $schema_text";
 2652: 				my $schema = $compartment->reval($schema_str);
 2653: 				if(scalar keys %{$schema}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2654: 					return {
 2655: 						input => $schema,
 2656: 						style => 'hash',
 2657: 						source => 'validator'
 2658: 					}
 2659: 				}
 2660: 			}
 2661: 		}
 2662: 		next unless $list;
 2663: 
 2664: 		my ($schema_block) = grep { $_->isa('PPI::Structure::Block') } $list->children;
 2665: 
 2666: 		next unless $schema_block;
 2667: 
 2668: 		my $schema = $self->_extract_schema_hash_from_block($schema_block);
 2669: 		return $self->_normalize_validator_schema($schema) if $schema;

					

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

 2670: 	}
 2671: 
 2672: 	return;
 2673: }
 2674: 
 2675: # --------------------------------------------------
 2676: # _extract_pv_schema
 2677: #
 2678: # Purpose:    Detect and extract a parameter schema
 2679: #             from a Params::Validate validate()
 2680: #             call in the method body.
 2681: #
 2682: # Entry:      $code - method body source string.
 2683: #
 2684: # Exit:       Returns a schema hashref with input,
 2685: #             style, and source keys on success,
 2686: #             or undef if no validate() call is
 2687: #             found or parsing fails.
 2688: #
 2689: # Side effects: None.
 2690: # --------------------------------------------------
 2691: sub _extract_pv_schema {
●2692 → 2702 → 2749 2692: 	my ($self, $code) = @_;
 2693: 
 2694: 	return unless $code =~ /\bvalidate\s*\(/;
 2695: 
 2696: 	my $doc = $self->_ppi($code) or return;
 2697: 
 2698: 	my $calls = $doc->find(sub {
 2699: 		$_[1]->isa('PPI::Token::Word') && ($_[1]->content eq 'validate' || $_[1]->content eq 'Params::Validate::validate')
 2700: 	}) or return;
 2701: 
 2702: 	for my $call (@$calls) {
 2703: 		my $list = $call->parent;
 2704: 		while ($list && !$list->isa('PPI::Structure::List')) {
 2705: 			$list = $list->parent;
 2706: 		}
 2707: 		if(!defined($list)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2708: 			my $next = $call->next_sibling();
 2709: 			my ($arglist, $schema_text) = $self->_parse_pv_call($next);
 2710: 
 2711: 			if($schema_text) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2712: 				my $compartment = Safe->new();
 2713: 				$compartment->permit_only(qw(:base_core :base_mem :base_orig));
 2714: 
 2715: 				my $schema_str = "my \$schema = $schema_text";
 2716: 				my $schema = $compartment->reval($schema_str);
 2717: 
 2718: 				if(scalar keys %{$schema}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2719: 					foreach my $arg(keys %{$schema}) {
 2720: 						my $field = $schema->{$arg};
 2721: 						if(my $type = $field->{'type'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2722: 							if($type eq 'ARRAYREF') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2723: 								$field->{'type'} = 'arrayref';
 2724: 							} elsif($type eq 'SCALAR') {
 2725: 								$field->{'type'} = 'string';
 2726: 							}
 2727: 						}
 2728: 						delete $field->{'callbacks'};
 2729: 					}
 2730: 
 2731: 					return {
 2732: 						input => $schema,
 2733: 						style => 'hash',
 2734: 						source => 'validator'
 2735: 					}
 2736: 				}
 2737: 			}
 2738: 		}
 2739: 		next unless $list;
 2740: 
 2741: 		my ($schema_block) = grep { $_->isa('PPI::Structure::Block') } $list->children;
 2742: 
 2743: 		next unless $schema_block;
 2744: 
 2745: 		my $schema = $self->_extract_schema_hash_from_block($schema_block);
 2746: 		return $self->_normalize_validator_schema($schema) if $schema;

					

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

 2747: 	}
 2748: 
 2749: 	return;
 2750: }
 2751: 
 2752: # --------------------------------------------------
 2753: # _parse_pv_call
 2754: #
 2755: # Purpose:    Split a Params::Validate call argument
 2756: #             string into its two components: the
 2757: #             first argument (typically \@_) and
 2758: #             the schema hash string.
 2759: #
 2760: # Entry:      $string - the raw argument string
 2761: #                       from the validate() call,
 2762: #                       including outer parentheses.
 2763: #
 2764: # Exit:       Returns a two-element list:
 2765: #               ($first_arg, $hash_str)
 2766: #             or an empty list if no comma is found
 2767: #             at brace depth zero (malformed call).
 2768: #
 2769: # Side effects: None.
 2770: # --------------------------------------------------
 2771: sub _parse_pv_call {
●2772 → 2786 → 2803 2772: 	my ($self, $string) = @_;
 2773: 
 2774: 	# Remove outer parentheses and whitespace
 2775: 	$string =~ s/^\s*\(\s*//;
 2776: 	$string =~ s/\s*\)\s*$//;
 2777: 
 2778: 	# Find the first comma at brace-depth 0, jumping over each balanced
 2779: 	# {...} block in one step via extract_bracketed rather than
 2780: 	# counting depth character by character
 2781: 	require Text::Balanced;
 2782: 	my $rest = $string;
 2783: 	my $comma_pos = 0;
 2784: 	my $found_comma = 0;
 2785: 
 2786: 	while (length $rest) {
 2787: 		if (substr($rest, 0, 1) eq '{') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2788: 			# extract_bracketed advances $rest past the extracted block
 2789: 			# in place, so $rest must not be re-truncated afterwards
 2790: 			my $extracted = Text::Balanced::extract_bracketed($rest, '{}');
 2791: 			return unless defined $extracted;	# Broken source code
 2792: 			$comma_pos += length $extracted;
 2793: 			next;
 2794: 		}
 2795: 		if (substr($rest, 0, 1) eq ',') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2796: 			$found_comma = 1;
 2797: 			last;
 2798: 		}
 2799: 		$comma_pos++;
 2800: 		$rest = substr($rest, 1);
 2801: 	}
 2802: 
 2803: 	return unless $found_comma;
 2804: 
 2805: 	my $first_arg = substr($string, 0, $comma_pos);
 2806: 	my $hash_str = substr($string, $comma_pos + 1);
 2807: 
 2808: 	# Trim whitespace
 2809: 	$first_arg =~ s/^\s+|\s+$//g;
 2810: 	$hash_str =~ s/^\s+|\s+$//g;
 2811: 
 2812: 	return ($first_arg, $hash_str);
 2813: }
 2814: 
 2815: # --------------------------------------------------
 2816: # _extract_moosex_params_schema
 2817: #
 2818: # Purpose:    Detect and extract a parameter schema
 2819: #             from a MooseX::Params::Validate
 2820: #             validated_hash() call in the method
 2821: #             body.
 2822: #
 2823: # Entry:      $code - method body source string.
 2824: #
 2825: # Exit:       Returns a schema hashref with input,
 2826: #             style, and source keys on success,
 2827: #             or undef if no validated_hash() call
 2828: #             is found or parsing fails.
 2829: #
 2830: # Side effects: None.
 2831: # --------------------------------------------------
 2832: sub _extract_moosex_params_schema
 2833: {
●2834 → 2844 → 2908 2834: 	my ($self, $code) = @_;
 2835: 
 2836: 	return unless $code =~ /\bvalidated_hash\s*\(/;
 2837: 
 2838: 	my $doc = $self->_ppi($code) or return;
 2839: 
 2840: 	my $calls = $doc->find(sub {
 2841: 		$_[1]->isa('PPI::Token::Word') && ($_[1]->content eq 'validated_hash')
 2842: 	}) or return;
 2843: 
 2844: 	for my $call (@$calls) {
 2845: 		my $list = $call->parent();
 2846: 		while ($list && !$list->isa('PPI::Structure::List')) {
 2847: 			$list = $list->parent;
 2848: 		}
 2849: 		if(!defined($list)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2850: 			my $next = $call->next_sibling();
 2851: 			my ($arglist, $schema_text) = $self->_parse_pv_call($next);
 2852: 
 2853: 			if($schema_text) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2854: 				my $compartment = Safe->new();
 2855: 				$compartment->permit_only(qw(:base_core :base_mem :base_orig));
 2856: 
 2857: 				my $schema_str = "my \$schema = { $schema_text }";
 2858: 				$schema_str =~ s/ArrayRef\[(.+?)\]/arrayref, element_type => $1/g;
 2859: 				my $schema = $compartment->reval($schema_str);
 2860: 
 2861: 				if(scalar keys %{$schema}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2862: 					foreach my $arg(keys %{$schema}) {
 2863: 						my $field = $schema->{$arg};
 2864: 						if(my $isa = delete $field->{'isa'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2865: 							$field->{'type'} = $isa;
 2866: 						}
 2867: 						if(exists($field->{'required'})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2868: 							my $required = delete $field->{'required'};
 2869: 							$field->{'optional'} = $required ? 0 : 1;
 2870: 						} else {
 2871: 							$field->{'optional'} = 1;
 2872: 						}
 2873: 						if(ref($field->{'default'}) eq 'CODE') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2874: 							delete $field->{'default'};	# TODO
 2875: 						}
 2876: 					}
 2877: 
 2878: 					foreach my $arg(keys %{$schema}) {
 2879: 						my $field = $schema->{$arg};
 2880: 						if(my $type = $field->{'type'}) {

					

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

 2881: 							if($type eq 'ARRAYREF') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2882: 								$field->{'type'} = 'arrayref';
 2883: 							} elsif($type eq 'SCALAR') {
 2884: 								$field->{'type'} = 'string';
 2885: 							}
 2886: 						}
 2887: 						delete $field->{'callbacks'};
 2888: 					}
 2889: 
 2890: 					return {
 2891: 						input => $schema,
 2892: 						style => 'hash',
 2893: 						source => 'validator'
 2894: 					}
 2895: 				}
 2896: 			}
 2897: 		}
 2898: 		next unless $list;
 2899: 
 2900: 		my ($schema_block) = grep { $_->isa('PPI::Structure::Block') } $list->children;
 2901: 
 2902: 		next unless $schema_block;
 2903: 
 2904: 		my $schema = $self->_extract_schema_hash_from_block($schema_block);
 2905: 		return $self->_normalize_validator_schema($schema) if $schema;

					

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

 2906: 	}
 2907: 
 2908: 	return;
 2909: }
 2910: 
 2911: # --------------------------------------------------
 2912: # _extract_schema_hash_from_block
 2913: #
 2914: # Purpose:    Extract a parameter schema hashref from
 2915: #             a PPI::Structure::Block node representing
 2916: #             the schema argument to a validator call
 2917: #             such as validate_strict({ ... }).
 2918: #
 2919: # Entry:      $block - a PPI::Structure::Block node.
 2920: #
 2921: # Exit:       Returns a hashref of parameter name to
 2922: #             spec hashref, or undef if parsing fails.
 2923: #
 2924: # Side effects: None.
 2925: #
 2926: # Notes:      Delegates to _parse_schema_hash which
 2927: #             expects a PPI node with a children()
 2928: #             method. This method exists to provide
 2929: #             a clear semantic name at the call site.
 2930: # --------------------------------------------------
 2931: sub _extract_schema_hash_from_block {
 2932: 	my ($self, $block) = @_;
 2933: 
 2934: 	return unless $block && $block->can('children');
 2935: 
 2936: 	my $result = $self->_parse_schema_hash($block);
 2937: 
 2938: 	return unless $result && ref($result) eq 'HASH' && $result->{input};
 2939: 
 2940: 	return $result->{input};

					

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

 2941: }
 2942: 
 2943: # --------------------------------------------------
 2944: # _normalize_validator_schema
 2945: #
 2946: # Purpose:    Normalise a raw validator schema
 2947: #             hashref (as extracted from PPI) into
 2948: #             the standard input spec format used
 2949: #             throughout the extractor.
 2950: #
 2951: # Entry:      $schema - hashref of parameter name
 2952: #                       to raw spec hashref, as
 2953: #                       produced by
 2954: #                       _extract_schema_hash_from_block.
 2955: #
 2956: # Exit:       Returns a hashref with keys:
 2957: #               input_style - 'hash'
 2958: #               input       - normalised param specs
 2959: #             Each param spec gains an explicit
 2960: #             optional key and _source / _type_confidence
 2961: #             metadata.
 2962: #
 2963: # Side effects: None.
 2964: # --------------------------------------------------
 2965: sub _normalize_validator_schema {
●2966 → 2970 → 2981 2966: 	my ($self, $schema) = @_;
 2967: 
 2968: 	my %input;
 2969: 
 2970: 	for my $name (keys %$schema) {
 2971: 		my $spec = $schema->{$name};
 2972: 
 2973: 		$input{$name} = {
 2974: 			%$spec,
 2975: 			optional => exists $spec->{optional} ? $spec->{optional} : 0,
 2976: 			_source => 'validator',
 2977: 			_type_confidence => 'high',
 2978: 		};
 2979: 	}
 2980: 
 2981: 	return {
 2982: 		input_style => 'hash',
 2983: 		input => \%input,
 2984: 	};
 2985: }
 2986: 
 2987: # --------------------------------------------------
 2988: # _extract_type_params_schema
 2989: #
 2990: # Purpose:    Detect and extract a parameter schema
 2991: #             from a Type::Params signature_for()
 2992: #             declaration for the current method,
 2993: #             located in the module-level document.
 2994: #
 2995: # Entry:      $code - method body source string
 2996: #                     (used to extract the function
 2997: #                     name for lookup).
 2998: #
 2999: # Exit:       Returns a schema hashref on success,
 3000: #             or undef if no signature_for
 3001: #             declaration is found or compilation
 3002: #             fails.
 3003: #
 3004: # Side effects: May fork a child process to compile
 3005: #               the signature in isolation.
 3006: # --------------------------------------------------
 3007: sub _extract_type_params_schema {
 3008: 	my ($self, $code) = @_;
 3009: 
 3010: 	my $function = $self->_extract_function_name($code) or return;
 3011: 
 3012: 	my $doc = $self->{_document} or return;
 3013: 	my $stmt = $self->_find_signature_statement($doc, $function) or return;
 3014: 
 3015: 	my $signature_expr = $self->_extract_signature_expression($stmt, $function) or return;
 3016: 
 3017: 	my $meta = $self->_compile_signature_isolated($function, $signature_expr) or return;
 3018: 
 3019: 	return $self->_build_schema_from_meta($meta);

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3020: }
 3021: 
 3022: # --------------------------------------------------
 3023: # _extract_function_name
 3024: #
 3025: # Purpose:    Extract the subroutine name from the
 3026: #             start of a method body string, used
 3027: #             to look up its Type::Params signature.
 3028: #
 3029: # Entry:      $code - method body source string.
 3030: #
 3031: # Exit:       Returns the subroutine name string,
 3032: #             or undef if no 'sub name' declaration
 3033: #             is found.
 3034: #
 3035: # Side effects: None.
 3036: # --------------------------------------------------
 3037: sub _extract_function_name {
 3038: 	my ($self, $code) = @_;
 3039: 	return $1 if $code =~ /^\s*sub\s+([a-zA-Z0-9_]+)/;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3040: 	return;
 3041: }
 3042: 
 3043: # --------------------------------------------------
 3044: # _find_signature_statement
 3045: #
 3046: # Purpose:    Search a PPI document for a
 3047: #             signature_for statement that
 3048: #             corresponds to a named function.
 3049: #
 3050: # Entry:      $doc      - PPI::Document to search.
 3051: #             $function - function name string.
 3052: #
 3053: # Exit:       Returns the matching PPI::Statement
 3054: #             node, or undef if none is found.
 3055: #
 3056: # Side effects: None.
 3057: # --------------------------------------------------
 3058: sub _find_signature_statement {
●3059 → 3067 → 3074 3059: 	my ($self, $doc, $function) = @_;
 3060: 
 3061: 	my $statements = $doc->find(
 3062: 		sub {
 3063: 			$_[1]->isa('PPI::Statement') && $_[1]->content =~ /^\s*signature_for\b/
 3064: 		}
 3065: 	) or return;
 3066: 
 3067: 	foreach my $stmt (@$statements) {
 3068: 		my $content = $stmt->content;
 3069: 		if ($content =~ /^\s*signature_for\s+\Q$function\E\b/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3070: 			return $stmt;

					

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

 3071: 		}
 3072: 	}
 3073: 
 3074: 	return;
 3075: }
 3076: 
 3077: # --------------------------------------------------
 3078: # _extract_signature_expression
 3079: #
 3080: # Purpose:    Extract the Type::Params signature
 3081: #             expression (everything after =>) from
 3082: #             a signature_for statement node.
 3083: #
 3084: # Entry:      $stmt     - PPI::Statement node.
 3085: #             $function - function name string,
 3086: #                         used in the match pattern.
 3087: #
 3088: # Exit:       Returns the signature expression
 3089: #             string, or undef if the pattern
 3090: #             does not match.
 3091: #
 3092: # Side effects: None.
 3093: # --------------------------------------------------
 3094: sub _extract_signature_expression {
●3095 → 3099 → 3103 3095: 	my ($self, $stmt, $function) = @_;
 3096: 
 3097: 	my $content = $stmt->content;
 3098: 
 3099: 	if ($content =~ /^\s*signature_for\s+\Q$function\E\s*=>\s*(.+?);?\s*$/s) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3100: 		return $1;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3101: 	}
 3102: 
 3103: 	return;
 3104: }
 3105: 
 3106: # --------------------------------------------------
 3107: # _compile_signature_isolated
 3108: #
 3109: # Purpose:    Compile and evaluate a Type::Params
 3110: #             signature expression in an isolated
 3111: #             process to extract parameter metadata
 3112: #             without polluting the current process.
 3113: #
 3114: #             Only runs when the caller passed
 3115: #             allow_signature_exec => 1 to new().
 3116: #             Extracting parameter types from a
 3117: #             Type::Params signature_for() declaration
 3118: #             requires actually building the type
 3119: #             objects at runtime -- there is no purely
 3120: #             static way to do it -- so this is real
 3121: #             execution of an excerpt of the target
 3122: #             module's own source. Every other code
 3123: #             path in this module is static (PPI-only)
 3124: #             analysis that never runs the target's
 3125: #             code, so this one feature must be opted
 3126: #             into explicitly rather than triggered
 3127: #             implicitly by extract_all().
 3128: #
 3129: #             A Safe compartment was previously tried
 3130: #             first as a "fast path" before falling
 3131: #             back to this subprocess unconditionally.
 3132: #             It was removed: Type::Params and
 3133: #             Types::Common pull in XS modules (e.g.
 3134: #             B.pm via Type::Params), and Safe cannot
 3135: #             host XS/dynamic loading at all, so the
 3136: #             compartment never succeeded for any real
 3137: #             signature_for() declaration -- it was
 3138: #             dead code that gave a false impression of
 3139: #             sandboxing while every real call fell
 3140: #             through to the unconditional subprocess
 3141: #             below.
 3142: #
 3143: # Entry:      $function        - function name string.
 3144: #             $signature_expr  - Type::Params
 3145: #                                signature expression
 3146: #                                string.
 3147: #
 3148: # Exit:       Returns a decoded JSON hashref
 3149: #             containing parameters and returns
 3150: #             metadata on success.
 3151: #             Returns undef without running anything if
 3152: #             allow_signature_exec was not enabled.
 3153: #             Croaks on unsafe expressions, timeout,
 3154: #             or compile errors.
 3155: #
 3156: # Side effects: May fork a child process with a
 3157: #               memory limit applied via
 3158: #               BSD::Resource if available.
 3159: #               Memory limiting is best-effort and
 3160: #               silently skipped on platforms where
 3161: #               BSD::Resource is unavailable.
 3162: # --------------------------------------------------
 3163: sub _compile_signature_isolated {
●3164 → 3166 → 3175 3164: 	my ($self, $function, $signature_expr) = @_;
 3165: 
 3166: 	unless ($self->{allow_signature_exec}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3167: 		carp "Skipping Type::Params signature_for($function) extraction: ",
 3168: 			'allow_signature_exec => 1 was not passed to new() ',
 3169: 			'(this would execute code from the target module)'
 3170: 			if $self->{verbose};
 3171: 		return;
 3172: 	}
 3173: 
 3174: 	# Remove comments
●[NOT COVERED] 3175 → 3183 → 3187 3175: 	$signature_expr =~ s/#.*$//mg;
 3176: 
 3177: 	# Reject obviously dangerous constructs. This is defense in depth
 3178: 	# only, not a real security boundary -- it is a denylist of literal
 3179: 	# tokens and cannot catch e.g. a symbolic-ref call built by string
 3180: 	# concatenation. The actual control here is the allow_signature_exec
 3181: 	# opt-in above: this code must never run against a module the caller
 3182: 	# has not already decided to trust enough to execute.
 3183: 	if ($signature_expr =~ /\b(?:system|exec|open|fork|require|do|eval|qx)\b/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3184: 		die 'Unsafe signature expression';
 3185: 	}
 3186: 
●[NOT COVERED] 3187 → 3187 → 3191 3187: 	if ($signature_expr =~ /[`{};]/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3188: 		die "Unsafe signature expression";
 3189: 	}
 3190: 
●[NOT COVERED] 3191 → 3284 → 3288 3191: 	my $payload = <<'PERL';
 3192: use strict;
 3193: use warnings;
 3194: use Type::Params -sigs;
 3195: use Types::Common -types;
 3196: use JSON::MaybeXS;
 3197: 
 3198: # Stub sub so Perl can parse it
 3199: sub FUNCTION_NAME {}
 3200: 
 3201: # Create the Type::Params signature object
 3202: my $sig = signature_for FUNCTION_NAME => SIGNATURE_EXPR;
 3203: 
 3204: # Extract parameters
 3205: my @sig_params = @{ $sig->parameters || [] };
 3206: my $pos = 0;
 3207: my @params;
 3208: 
 3209: # if ($sig->method) {
 3210:     # The $self value
 3211:     # push @params, {
 3212:         # name     => 'arg0',
 3213:         # optional => 0,
 3214:         # position => $pos++,
 3215:     # };
 3216: # }
 3217: 
 3218: for my $p (@sig_params) {
 3219: 	push @params, {
 3220: 		name => "arg$pos",
 3221: 		optional => $p->optional ? 1 : 0,
 3222: 		position => $pos,
 3223: 		type => $p->type->name
 3224: 	};
 3225: 	$pos++;
 3226: }
 3227: 
 3228: # Extract return type
 3229: my $returns;
 3230: if (my $r = $sig->returns_scalar) {
 3231: 	$returns = {
 3232: 		context => 'scalar',
 3233: 		type => $r ? $r->name : 'unknown',
 3234: 	};
 3235: } elsif ($r = $sig->returns_list) {
 3236: 	$returns = {
 3237: 		context => 'list',
 3238: 		type => $r ? $r->name : 'unknown',
 3239: 	};
 3240: }
 3241: 
 3242: print encode_json({
 3243: 	parameters => \@params,
 3244: 	returns => $returns,
 3245: });
 3246: PERL
 3247: 
 3248: 	# Substitute function name and signature expression
 3249: 	$payload =~ s/FUNCTION_NAME/$function/g;
 3250: 	$payload =~ s/SIGNATURE_EXPR/$signature_expr/;
 3251: 
 3252: 	# Run in an isolated Perl process
 3253: 	my ($wtr, $rdr, $err) = (undef, undef, gensym);
 3254: 	local %ENV;
 3255: 
 3256: 	# Apply memory limit if BSD::Resource is available.
 3257: 	# This module is Unix-only and not available on Windows,
 3258: 	# so we guard the call and skip silently if not present.
 3259: 	eval {
 3260: 		require BSD::Resource;
 3261: 		BSD::Resource::setrlimit(
 3262: 			BSD::Resource::RLIMIT_AS(),
 3263: 			$MEMORY_LIMIT_BYTES,
 3264: 			$MEMORY_LIMIT_BYTES
 3265: 		);
 3266: 	};
 3267: 	# Ignore failure — resource limiting is best-effort only
 3268: 
 3269: 	my $pid = open3($wtr, $rdr, $err, $^X, '-T');
 3270: 
 3271: 	print $wtr $payload;
 3272: 	close $wtr;
 3273: 
 3274: 	local $SIG{ALRM} = sub { croak 'Signature compile timeout' };
 3275: 	eval { alarm($SIGNATURE_TIMEOUT_SECS) };	# no-op on Windows
 3276: 
 3277: 	my $stdout = do { local $/; <$rdr> };
 3278: 	my $stderr = do { local $/; <$err> };
 3279: 
 3280: 	eval { alarm 0 };
 3281: 
 3282: 	waitpid($pid, 0);
 3283: 
 3284: 	if ($stderr && length $stderr) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3285: 		croak "Error compiling signature:\n$stderr";
 3286: 	}
 3287: 
 3288: 	return decode_json($stdout);

					

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

 3289: }
 3290: 
 3291: # --------------------------------------------------
 3292: # _build_schema_from_meta
 3293: #
 3294: # Purpose:    Convert the parameter and return type
 3295: #             metadata produced by
 3296: #             _compile_signature_isolated into a
 3297: #             standard schema hashref.
 3298: #
 3299: # Entry:      $meta - hashref with 'parameters'
 3300: #                     arrayref and optional
 3301: #                     'returns' hashref, as decoded
 3302: #                     from the isolated compile
 3303: #                     JSON output.
 3304: #
 3305: # Exit:       Returns a schema hashref with input,
 3306: #             output, style, source, _notes, and
 3307: #             _confidence keys.
 3308: #
 3309: # Side effects: None.
 3310: #
 3311: # Notes:      Unknown Type::Params type names are
 3312: #             mapped to 'string' with a note added
 3313: #             and confidence downgraded to 'medium'.
 3314: # --------------------------------------------------
 3315: sub _build_schema_from_meta {
●3316 → 3333 → 3350 3316: 	my ($self, $meta) = @_;
 3317: 
 3318: 	my %type_map = (
 3319: 		Num => 'number',
 3320: 		Int => 'integer',
 3321: 		Str => 'string',
 3322: 		Bool => 'boolean',
 3323: 		Object  => 'object',
 3324: 		ArrayRef => 'array',
 3325: 		HashRef  => 'object',
 3326: 	);
 3327: 
 3328: 	my $input;
 3329: 	my $position = 0;
 3330: 	my $confidence = 'high';
 3331: 	my @notes = ('Type::Params detected');
 3332: 
 3333: 	foreach my $p (@{ $meta->{parameters} || [] }) {
 3334: 		my $type = $type_map{ $p->{type} } // 'string';
 3335: 
 3336: 		if (!exists $type_map{$p->{type}}) {

					

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

 3337: 			push @notes, "Unknown type $p->{type}, defaulting to string";
 3338: 			$confidence = 'medium';
 3339: 		}
 3340: 
 3341: 		$input->{"arg$position"} = {
 3342: 			type => $type,
 3343: 			position => $position,
 3344: 			optional => $p->{optional} ? 1 : 0,
 3345: 		};
 3346: 
 3347: 		$position++;
 3348: 	}
 3349: 
●3350 → 3352 → 3366 3350: 	my $output;
 3351: 
 3352: 	if (my $ret = $meta->{returns}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3353: 		my $type = $type_map{ $ret->{type} } // 'string';
 3354: 
 3355: 		if (!exists $type_map{$ret->{type}}) {

					

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

 3356: 			push @notes, "Unknown return type $ret->{type}, defaulting to string";
 3357: 			$confidence = 'medium';
 3358: 		}
 3359: 
 3360: 		$output = {
 3361: 			type => $type,
 3362: 			"_$ret->{context}_context" => { type => $type },
 3363: 		};
 3364: 	}
 3365: 
 3366: 	return {
 3367: 		input  => $input,
 3368: 		output => $output,
 3369: 		style  => 'hash',
 3370: 		source => 'validator',
 3371: 		_notes => \@notes,
 3372: 		_confidence => {
 3373: 			input => $confidence,
 3374: 		},
 3375: 	};
 3376: }
 3377: 
 3378: # --------------------------------------------------
 3379: # _analyze_pod
 3380: #
 3381: # Purpose:    Parse POD documentation for a method
 3382: #             and extract parameter names, types,
 3383: #             constraints, and optionality from
 3384: #             multiple POD patterns.
 3385: #
 3386: # Entry:      $pod - string of POD content as
 3387: #                    returned by _extract_pod_before.
 3388: #                    May be undef or empty.
 3389: #
 3390: # Exit:       Returns a hashref of parameter name
 3391: #             to parameter spec hashref. Returns an
 3392: #             empty hashref if no POD is provided
 3393: #             or no parameters are found.
 3394: #
 3395: # Side effects: Carps when a semantic type is
 3396: #               detected, advising the caller to
 3397: #               set config->properties.
 3398: #               Logs progress to stdout when
 3399: #               verbose is set.
 3400: #
 3401: # Notes:      Three pattern strategies are tried
 3402: #             in order: (1) named Parameters section,
 3403: #             (2) inline $name - type format,
 3404: #             (3) =over/=item list. Parameters found
 3405: #             earlier take precedence over later
 3406: #             discoveries. Default values from POD
 3407: #             are merged in last.
 3408: # --------------------------------------------------
 3409: sub _analyze_pod {
●3410 → 3419 → 3435 3410: 	my ($self, $pod) = @_;
 3411: 
 3412: 	return {} unless $pod;
 3413: 
 3414: 	my %params;
 3415: 	my $position_counter = 0;
 3416: 
 3417: 	# Check for positional arguments in method signature
 3418: 	# Pattern: =head2 method_name($arg1, $arg2, $arg3)
 3419: 	if ($pod =~ /=head2\s+\w+\s*\(([^)]+)\)/s) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3420: 		my $sig = $1;
 3421: 		# Extract parameter names in order
 3422: 		my @sig_params = $sig =~ /\$(\w+)/g;
 3423: 
 3424: 		# Skip $self or $class
 3425: 		shift @sig_params if @sig_params && $sig_params[0] =~ /^(self|class)$/i;
 3426: 
 3427: 		# Assign positions
 3428: 		foreach my $param (@sig_params) {
 3429: 			$params{$param}{position} //= $position_counter;
 3430: 			$self->_log("  POD: $param has position $params{$param}{position}");
 3431: 			$position_counter++;
 3432: 		}
 3433: 	}
 3434: 
●3435 → 3440 → 3445 3435: 	$self->_log("  POD: Found $position_counter unnamed parameters to add to the position list");
 3436: 
 3437: 	# Pattern 1: Parse line-by-line in Parameters section
 3438: 	# First, extract the Parameters section
 3439: 	my $param_section;
 3440: 	if($pod =~ /(?:Parameters?|Arguments?|Inputs?):?\s*\n((?:\s*\$.*\n)+)/si) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3441: 		$param_section = $1;
 3442: 	} elsif ($pod =~ /^=head\d+\s+(?:Parameters?|Arguments?|Inputs?)\b.*?\n(.*?)(?=^=head|\Z)/msi) {
 3443: 		$param_section = $1;
 3444: 	}
●3445 → 3445 → 3522 3445: 	if($param_section) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3446: 		my $param_order = 0;
 3447: 
 3448: 		$self->_log("  POD: Scan for named parameters in '$param_section'");
 3449: 		# Now parse each line that starts with $varname
 3450: 		foreach my $line (split /\n/, $param_section) {
 3451: 			if ($line =~ /C<\$(\w+)>\s*\((Required|Mandatory)\)/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3452: 				$params{$1}{optional} = 0;
 3453: 				$self->_log("  POD: $1 marked required from item header");
 3454: 			}
 3455: 
 3456: 			# Match: $name - type (constraints), description
 3457: 			# or:	$name - type, description
 3458: 			# or:	$name - type
 3459: 			if(($line =~ /^\s*\$(\w+)\s*-\s*(\w+)(?:\s*\(([^)]+)\))?\s*,?\s*(.*)$/i) ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3460: 			   ($line =~ /^\s*C<\$(\w+)>\s*-\s*(\w+)(?:\s*\(([^)]+)\))?\s*,?\s*(.*)$/i)) {
 3461: 				my ($name, $type, $constraint, $desc) = ($1, lc($2), $3, $4);
 3462: 
 3463: 				# Clean up
 3464: 				$desc =~ s/^\s+|\s+$//g if $desc;
 3465: 
 3466: 				# Skip common non-parameters
 3467: 				next if $name =~ /^(self|class|return|returns?)$/i;
 3468: 
 3469: 				$params{$name} ||= { _source => 'pod' };
 3470: 
 3471: 				# If we haven't already assigned a position from the signature, use order in Parameters section
 3472: 				unless (exists $params{$name}{position}) {

					

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

 3473: 					$params{$name}{position} = $param_order++;
 3474: 					$self->_log("  POD: $name has position $params{$name}{position} (from Parameters order)");
 3475: 				}
 3476: 
 3477: 				# Normalize type names
 3478: 				$type = 'integer' if $type eq 'int';
 3479: 				$type = 'number' if $type eq 'num' || $type eq 'float';
 3480: 				$type = 'boolean' if $type eq 'bool';
 3481: 				$type = 'arrayref' if $type eq 'array';
 3482: 				$type = 'hashref' if $type eq 'hash';
 3483: 
 3484: 				$params{$name}{type} = $type;
 3485: 
 3486: 				# Parse constraints
 3487: 				if($constraint) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3488: 					$self->_parse_constraints($params{$name}, $constraint);
 3489: 				}
 3490: 
 3491: 				# Check for optional/required in description OR constraint.
 3492: 				# Use word boundaries to avoid matching "optionally" as "optional".
 3493: 				my $full_text = ($constraint || '') . ' ' . ($desc || '');
 3494: 				if ($full_text =~ /\boptional\b/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3495: 					$params{$name}{optional} = 1;
 3496: 					$self->_log("  POD: $name marked as optional");
 3497: 				} elsif ($full_text =~ /required|mandatory/i) {
 3498: 					$params{$name}{optional} = 0;
 3499: 					$self->_log("  POD: $name marked as required");
 3500: 				}
 3501: 
 3502: 				# Detect semantic types:
 3503: 				if ($desc =~ /\b(email|url|uri|path|filename)\b/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3504: 					# TODO: ensure properties is set to 1 in $config
 3505: 					carp('Manually set config->properties to 1 in ', $self->{'input_file'});
 3506: 					$params{$name}{semantic} = lc($1);
 3507: 				}
 3508: 
 3509: 				# Look for regex patterns
 3510: 				if ($desc && $desc =~ m{matches?\s+(/[^/]+/|qr/.+?/)}i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3511: 					$params{$name}{matches} = $1;
 3512: 				}
 3513: 
 3514: 				$self->_log("  POD: Found parameter '$name' in parameters section, type=$type" .
 3515: 						($constraint ? " ($constraint)" : '') .
 3516: 						($desc ? " - $desc" : ''));
 3517: 			}
 3518: 		}
 3519: 	}
 3520: 
 3521: 	# Pattern 2: Also try the inline format in case Parameters: section wasn't found
●3522 → 3522 → 3570 3522: 	while ($pod =~ /\$(\w+)\s*-\s*(string|integer|int|number|num|float|boolean|bool|arrayref|array|hashref|hash|object|any)(?:\s*\(([^)]+)\))?\s*,?\s*(.*)$/gim) {
 3523: 		my ($name, $type, $constraint, $desc) = ($1, lc($2), $3, $4);
 3524: 
 3525: 		# Only process if we haven't already found this param in the Parameters section
 3526: 		next if exists $params{$name};
 3527: 
 3528: 		# Clean up description - remove leading/trailing whitespace
 3529: 		$desc =~ s/^\s+|\s+$//g if $desc;
 3530: 
 3531: 		# Skip common words that aren't parameters
 3532: 		next if $name =~ /^(self|class|return|returns?)$/i;
 3533: 
 3534: 		$params{$name} ||= { _source => 'pod' };
 3535: 
 3536: 		# Normalize type names
 3537: 		$type = 'integer' if $type eq 'int';
 3538: 		$type = 'number' if $type eq 'num' || $type eq 'float';
 3539: 		$type = 'boolean' if $type eq 'bool';
 3540: 		$type = 'arrayref' if $type eq 'array';
 3541: 		$type = 'hashref' if $type eq 'hash';
 3542: 
 3543: 		$params{$name}{type} = $type;
 3544: 
 3545: 		# Parse constraints
 3546: 		if ($constraint) {

					

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

 3547: 			$self->_parse_constraints($params{$name}, $constraint);
 3548: 		}
 3549: 
 3550: 		# Check for optional/required in description.
 3551: 		# Use word boundaries to avoid matching "optionally" as "optional".
 3552: 		if ($desc) {

					

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

 3553: 			if ($desc =~ /\boptional\b/i) {

					

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

 3554: 				$params{$name}{optional} = 1;
 3555: 			} elsif ($desc =~ /required|mandatory/i) {
 3556: 				$params{$name}{optional} = 0;
 3557: 			}
 3558: 
 3559: 			# Look for regex patterns in description
 3560: 			if ($desc =~ m{matches?\s+(/[^/]+/|qr/.+?/)}i) {

					

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

 3561: 				$params{$name}{matches} = $1;
 3562: 			}
 3563: 		}
 3564: 
 3565: 		$self->_log("  POD: Found parameter '$name' in the inline documentation, type=$type" .
 3566: 					($constraint ? " ($constraint)" : ''));
 3567: 	}
 3568: 
 3569: 	# Pattern 3: Parse =over /=item list (supports bullets and C<>)
●3570 → 3570 → 3634 3570: 	while ($pod =~ /=item\s+(?:\*\s*)?(?:C<)?\$(\w+)\b(?:>)?\s*(?:-.*)?\n?(.*?)(?==item|\=back|\=head)/sig) {
 3571: 		my $name = $1;
 3572: 		my $desc = $2;
 3573: 
 3574: 		# Never allow empty or undefined parameter names
 3575: 		next unless defined $name && length $name;
 3576: 
 3577: 		$desc =~ s/^\s+|\s+$//g;
 3578: 
 3579: 		# Skip common non-parameters
 3580: 		next if $name =~ /^(self|class|return|returns?)$/i;
 3581: 
 3582: 		$params{$name} ||= { _source => 'pod' };
 3583: 
 3584: 		# Explicit typed form only:
 3585: 		#	$param - type (constraints)
 3586: 		if ($desc =~ /^\s*(string|integer|int|number|num|float|boolean|bool|array|arrayref|hash|hashref|any)\b(?:\s*\(([^)]+)\))?/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3587: 			my $type = lc($1);
 3588: 			my $constraint = $2;
 3589: 
 3590: 			# Normalize type names
 3591: 			$type = 'integer' if $type eq 'int';
 3592: 			$type = 'number' if $type eq 'num' || $type eq 'float';
 3593: 			$type = 'boolean' if $type eq 'bool';
 3594: 			$type = 'arrayref' if $type eq 'array';
 3595: 			$type = 'hashref' if $type eq 'hash';
 3596: 
 3597: 			$params{$name}{type} = $type;
 3598: 
 3599: 			if ($constraint) {

					

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

 3600: 				$self->_parse_constraints($params{$name}, $constraint);
 3601: 			}
 3602: 
 3603: 			$self->_log("  POD: Explicit type '$type' for $name");
 3604: 		} else {
 3605: 			# Heuristic inference from description text
 3606: 			if ($desc =~ /\bstring\b/i) {

					

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

 3607: 				$params{$name}{type} = 'string';
 3608: 			} elsif ($desc =~ /\b(int|integer)\b/i) {
 3609: 				$params{$name}{type} = 'integer';
 3610: 			} elsif ($desc =~ /\b(num|number|float)\b/i) {
 3611: 				$params{$name}{type} = 'number';
 3612: 			} elsif ($desc =~ /\b(bool|boolean)\b/i) {
 3613: 				$params{$name}{type} = 'boolean';
 3614: 			}
 3615: 		}
 3616: 
 3617: 		# Check for optional/required in description.
 3618: 		# Use word boundaries to avoid matching "optionally" as "optional".
 3619: 		if ($desc =~ /\boptional\b/i) {

					

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

 3620: 			$params{$name}{optional} = 1;
 3621: 		} elsif ($desc =~ /required|mandatory/i) {
 3622: 			$params{$name}{optional} = 0;
 3623: 		}
 3624: 
 3625: 		# Look for regex patterns
 3626: 		if ($desc =~ m{matches?\s+(/[^/]+/|qr/.+?/)}i) {

					

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

 3627: 			$params{$name}{matches} = $1;
 3628: 		}
 3629: 
 3630: 		$self->_log("  POD: Found parameter '$name' from =item list");
 3631: 	}
 3632: 
 3633: 	# Extract default values from POD
●3634 → 3635 → 3647 3634: 	my $pod_defaults = $self->_extract_defaults_from_pod($pod);
 3635: 	foreach my $param (keys %$pod_defaults) {
 3636: 		if (exists $params{$param}) {

					

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

 3637: 			$params{$param}{_default} = $pod_defaults->{$param};
 3638: 			$params{$param}{optional} = 1 unless defined $params{$param}{optional};
 3639: 			$self->_log(sprintf("  POD: %s has default value: %s",
 3640: 				$param,
 3641: 				defined($pod_defaults->{$param}) ? $pod_defaults->{$param} : 'undef'
 3642: 			));
 3643: 		}
 3644: 	}
 3645: 
 3646: 	# Default undocumented optionality: documented params are REQUIRED unless stated otherwise
●3647 → 3647 → 3662 3647: 	for my $name (keys %params) {
 3648: 		next if $name =~ /^(self|class)$/i;
 3649: 
 3650: 		# TODO: if optionality was never explicitly set, assume required.
 3651: 		# Currently disabled as it breaks some schemas — revisit in a future pass.
 3652: 		# if (!exists $params{$name}{optional}) {
 3653: 			# $params{$name}{optional} = 0;
 3654: 			# $self->_log("  POD: $name assumed required (no optional/default specified)");
 3655: 		# }
 3656: 	}
 3657: 
 3658: 	# Pattern 0: =head3|4 Input formal spec — highest-priority type source.
 3659: 	# Runs last so positional matching can use positions set by earlier patterns.
 3660: 	# Accepts positional array format: [ {type=>'...'}, ... ]
 3661: 	# and named hash format:           { name => {type=>'...'}, ... }
●3662 → 3662 → 3707 3662: 	if ($pod =~ /=head[34]\s+Input\b(.*?)(?==head|\z)/si) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3663: 		my $block = $1;
 3664: 		$block =~ s/\A\s+//;
 3665: 
 3666: 		if ($block =~ /\A\[/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3667: 			# Positional format: each {…} maps to the param at that array index.
 3668: 			my $idx = 0;
 3669: 			while ($block =~ /\{([^}]*)\}/g) {
 3670: 				my $spec = $1;
 3671: 				my ($name) = grep { ($params{$_}{position} // -1) == $idx }

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3672: 				             keys %params;
 3673: 				if (defined $name) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3674: 					$params{$name}{_from_input_spec} = 1;
 3675: 					if (my $t = $self->_map_formal_input_type($spec)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3676: 						$params{$name}{type} = $t;
 3677: 						$self->_log("  POD: $name type '$t' from =head Input (positional $idx)");
 3678: 					}
 3679: 					if ($spec =~ /\boptional\s*=>\s*(0|1)/i) {

					

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

 3680: 						$params{$name}{optional} = $1 + 0;
 3681: 					}
 3682: 				}
 3683: 				$idx++;
 3684: 			}
 3685: 		} elsif ($block =~ /\A\{/) {
 3686: 			# Named format: each 'name => {…}' entry maps directly by name.
 3687: 			while ($block =~ /\b(\w+)\s*=>\s*\{([^}]*)\}/g) {
 3688: 				my ($name, $spec) = ($1, $2);
 3689: 				next if $name =~ /^(self|class)$/i;
 3690: 				$params{$name} //= { _source => 'pod' };
 3691: 				$params{$name}{_from_input_spec} = 1;
 3692: 				if (my $t = $self->_map_formal_input_type($spec)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3693: 					$params{$name}{type} = $t;
 3694: 					$self->_log("  POD: $name type '$t' from =head Input (named)");
 3695: 				}
 3696: 				if ($spec =~ /\boptional\s*=>\s*(0|1)/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3697: 					$params{$name}{optional} = $1 + 0;
 3698: 				}
 3699: 			}
 3700: 			# A named-format Input spec signals a hash/named API.  Positional
 3701: 			# info from signature analysis is not meaningful here and causes
 3702: 			# "param X missing position" errors when params are mixed.
 3703: 			delete $params{$_}{position} for keys %params;
 3704: 		}
 3705: 	}
 3706: 
 3707: 	return \%params;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3708: }
 3709: 
 3710: # --------------------------------------------------
 3711: # _map_formal_input_type
 3712: #
 3713: # Purpose:    Extract and normalise the type string
 3714: #             from a parameter spec fragment such as
 3715: #             "type => 'scalar | scalarref'".
 3716: #             Handles union types by returning the
 3717: #             canonical ATG type for the first
 3718: #             recognised alternative.
 3719: #
 3720: # Entry:      $spec - text content of a { } block
 3721: #                     from a =head3|4 Input spec.
 3722: #
 3723: # Exit:       Canonical type string, or undef when
 3724: #             no 'type' key is present or the value
 3725: #             is not a recognised type name.
 3726: # --------------------------------------------------
 3727: sub _map_formal_input_type {
●3728 → 3755 → 3758 3728: 	my ($self, $spec) = @_;
 3729: 	return undef unless $spec =~ /\btype\s*=>\s*['"]([^'"]+)['"]/i;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3730: 	my $raw = lc($1);
 3731: 	$raw =~ s/\s+//g;
 3732: 
 3733: 	my %map = (
 3734: 		scalar    => 'string',
 3735: 		scalarref => 'string',
 3736: 		str       => 'string',
 3737: 		string    => 'string',
 3738: 		int       => 'integer',
 3739: 		integer   => 'integer',
 3740: 		num       => 'number',
 3741: 		number    => 'number',
 3742: 		float     => 'number',
 3743: 		bool      => 'boolean',
 3744: 		boolean   => 'boolean',
 3745: 		array     => 'arrayref',
 3746: 		arrayref  => 'arrayref',
 3747: 		hash      => 'hashref',
 3748: 		hashref   => 'hashref',
 3749: 		object    => 'object',
 3750: 		any       => 'any',
 3751: 		undef     => 'undef',
 3752: 		coderef   => 'coderef',
 3753: 	);
 3754: 
 3755: 	for my $t (split /\|/, $raw) {
 3756: 		return $map{$t} if exists $map{$t};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3757: 	}
 3758: 	return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3759: }
 3760: 
 3761: # --------------------------------------------------
 3762: # _analyze_output
 3763: #
 3764: # Purpose:    Orchestrate analysis of a method's
 3765: #             return value by combining POD return
 3766: #             section parsing, code return statement
 3767: #             analysis, boolean detection, context
 3768: #             detection, void detection, chaining
 3769: #             detection, and error convention
 3770: #             detection.
 3771: #
 3772: # Entry:      $pod         - POD string for the method.
 3773: #             $code        - method body source string.
 3774: #             $method_name - name of the method being
 3775: #                            analysed, used for
 3776: #                            boolean heuristics.
 3777: #
 3778: # Exit:       Returns a hashref describing the
 3779: #             output type and behaviour, or an empty
 3780: #             hashref if nothing could be determined.
 3781: #             Keys include: type, value, isa, and
 3782: #             various _* metadata keys.
 3783: #
 3784: # Side effects: Logs progress to stdout when
 3785: #               verbose is set.
 3786: # --------------------------------------------------
 3787: sub _analyze_output {
 3788: 	my ($self, $pod, $code, $method_name) = @_;
 3789: 
 3790: 	my %output;
 3791: 
 3792: 	$self->_analyze_output_from_pod(\%output, $pod);
 3793: 	$self->_analyze_output_from_code(\%output, $code, $method_name);
 3794: 	$self->_enhance_boolean_detection(\%output, $pod, $code, $method_name);
 3795: 	$self->_detect_list_context(\%output, $code);
 3796: 	$self->_detect_void_context(\%output, $code, $method_name);
 3797: 	$self->_detect_chaining_pattern(\%output, $code);
 3798: 	$self->_detect_error_conventions(\%output, $code);
 3799: 
 3800: 	$self->_validate_output(\%output) if keys %output;
 3801: 
 3802: 	# Don't return empty output
 3803: 	return (keys %output) ? \%output : {};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3804: }
 3805: 
 3806: # --------------------------------------------------
 3807: # _analyze_output_from_pod
 3808: #
 3809: # Purpose:    Parse the POD documentation for a
 3810: #             method's return value and populate
 3811: #             an output hashref with type, value,
 3812: #             and behaviour information.
 3813: #
 3814: # Entry:      $output - hashref to populate
 3815: #                       (modified in place).
 3816: #             $pod    - POD string for the method.
 3817: #
 3818: # Exit:       Returns nothing. Modifies $output
 3819: #             in place.
 3820: #
 3821: # Side effects: Logs detections to stdout when
 3822: #               verbose is set.
 3823: #
 3824: # Notes:      Two patterns are tried: (1) a
 3825: #             'Returns:' section of up to 3 lines,
 3826: #             and (2) an inline 'returns X' phrase.
 3827: #             The section pattern takes precedence.
 3828: # --------------------------------------------------
 3829: sub _analyze_output_from_pod {
●3830 → 3834 → 0 3830: 	my ($self, $output, $pod) = @_;
 3831: 	my %VALID_OUTPUT_TYPES = map { $_ => 1 }
 3832: 		qw(string integer number float boolean arrayref hashref object coderef void undef);
 3833: 
 3834: 	if ($pod) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3835: 		# Pattern 0: =head4 Output formal spec (highest priority — explicit over heuristic)
 3836: 		# The outer container shape determines the return type:
 3837: 		#   (...)  — list/array of items
 3838: 		#   [...]  — arrayref  (bare [] = empty/void, skip)
 3839: 		#   {...}  — hashref spec; look for type => inside, or isa => for object
 3840: 		if($pod =~ /=head4\s+Output\b(.*?)(?==head|\z)/si) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3841: 			my $block = $1;
 3842: 			$block =~ s/^\s+//;
 3843: 			if($block =~ /^\(/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3844: 				$output->{type} = 'array';
 3845: 				$self->_log("  OUTPUT: type 'array' from =head4 Output list notation");
 3846: 			} elsif($block =~ /^\[/) {
 3847: 				unless($block =~ /^\[\s*\]/) {

					

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

 3848: 					$output->{type} = 'arrayref';
 3849: 					$self->_log("  OUTPUT: type 'arrayref' from =head4 Output arrayref notation");
 3850: 				}
 3851: 			} elsif($block =~ /^\{/) {
 3852: 				if($block =~ /type\s*=>\s*['"]?(\w[\w:]*?)['"]?\s*[,}]/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3853: 					my $type = lc($1);
 3854: 					$type = 'hashref'  if $type eq 'hash';
 3855: 					$type = 'arrayref' if $type eq 'array';
 3856: 					if($VALID_OUTPUT_TYPES{$type}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3857: 						$output->{type} = $type;
 3858: 						$self->_log("  OUTPUT: type '$type' from =head4 Output formal spec");
 3859: 					} elsif($block =~ /\bisa\s*=>/) {
 3860: 						$output->{type} = 'object';
 3861: 						$self->_log("  OUTPUT: type 'object' from =head4 Output isa spec");
 3862: 					}
 3863: 				} elsif($block =~ /\bisa\s*=>/) {
 3864: 					$output->{type} = 'object';
 3865: 					$self->_log("  OUTPUT: type 'object' from =head4 Output isa spec");
 3866: 				}
 3867: 			}
 3868: 		}
 3869: 
 3870: 		# Pattern 1: Returns: section
 3871: 		# Up to 3 lines
 3872: 		if ($pod =~ /Returns?:\s+([^\n]+(?:\n[^\n]+){0,2})/si) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3873: 			my $returns_desc = $1;
 3874: 			$returns_desc =~ s/^\s+|\s+$//g;
 3875: 
 3876: 			$self->_log("  OUTPUT: Found Returns section: $returns_desc");
 3877: 
 3878: 			# Try to infer type from description (skip if Pattern 0 already set type)
 3879: 			if (!$output->{type} && $returns_desc =~ /\b(string|text)\b/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3880: 				$output->{type} = 'string';
 3881: 			} elsif (!$output->{type} && $returns_desc =~ /\b(integer|int|count)\b/i) {
 3882: 				$output->{type} = 'integer';
 3883: 			} elsif (!$output->{type} && $returns_desc =~ /\b(float|decimal|number)\b/i) {
 3884: 				$output->{type} = 'number';
 3885: 			} elsif (!$output->{type} && $returns_desc =~ /\b(boolean|true|false)\b/i) {
 3886: 				$output->{type} = 'boolean';
 3887: 			} elsif (!$output->{type} && $returns_desc =~ /\b(array|list)\b/i) {
 3888: 				$output->{type} = 'arrayref';
 3889: 			} elsif (!$output->{type} && $returns_desc =~ /\b(hash|hashref|dictionary)\b/i) {
 3890: 				$output->{type} = 'hashref';
 3891: 			} elsif (!$output->{type} && $returns_desc =~ /\b(object|instance)\b/i) {
 3892: 				$output->{type} = 'object';
 3893: 			} elsif (!$output->{type} && $returns_desc =~ /\bundef\b/i) {
 3894: 				$output->{type} = 'undef';
 3895: 			}
 3896: 
 3897: 			# Look for specific values
 3898: 			if ($returns_desc =~ /\b1\s+(?:on\s+success|if\s+successful)\b/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3899: 				$output->{value} = 1;
 3900: 				if(defined($output->{'type'}) && ($output->{type} eq 'scalar')) {

					

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

 3901: 					$output->{type} = 'boolean';
 3902: 				} else {
 3903: 					$output->{type} ||= 'boolean';
 3904: 				}
 3905: 				$self->_log("  OUTPUT: Returns 1 on success");
 3906: 			} elsif ($returns_desc =~ /\b0\s+(?:on\s+failure|if\s+fail)\b/i) {
 3907: 				$output->{alt_value} = 0;
 3908: 			} elsif ($returns_desc =~ /dies\s+on\s+(?:error|failure)/i) {
 3909: 				$output->{_STATUS} = 'LIVES';
 3910: 				$self->_log('  OUTPUT: Should not die on success');
 3911: 			}
 3912: 			if ($returns_desc =~ /\b(true|false)\b/i) {

					

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

 3913: 				$output->{type} ||= 'boolean';
 3914: 			}
 3915: 			if ($returns_desc =~ /\bundef\b/i) {

					

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

 3916: 				$output->{optional} = 1;
 3917: 			}
 3918: 		}
 3919: 
 3920: 		# Pattern 2: Inline "returns X"
 3921: 		if((!$output->{type}) && ($pod =~ /returns?\s+(?:an?\s+)?(\w+)/i)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3922: 			my $type = lc($1);
 3923: 
 3924: 			$type = 'boolean' if $type =~ /^(true|false|bool)$/;
 3925: 			# Skip if it's just a number (like "returns 1")
 3926: 			$type = 'integer' if $type eq 'int';
 3927: 			$type = 'number' if $type =~ /^(num|float)$/;
 3928: 			$type = 'arrayref' if $type eq 'array';
 3929: 			$type = 'hashref' if $type eq 'hash';
 3930: 
 3931: 			if($type =~ /^\d+$/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3932: 				if($type eq '1' || $type eq '0') {

					

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

 3933: 					# Try hard to guess if the result is a boolean
 3934: 					if($pod =~ /1 on success.+0 (on|if) /i) {

					

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

 3935: 						$type = 'boolean';
 3936: 					} elsif($pod =~ /return 0 .+ 1 on success/) {
 3937: 						$type = 'boolean';
 3938: 					} else {
 3939: 						$type = 'integer';
 3940: 					}
 3941: 				} else {
 3942: 					$type = 'integer';
 3943: 				}
 3944: 			}
 3945: 
 3946: 			$type = 'arrayref' if !$type && $pod =~ /returns?\s+.+\slist\b/i;
 3947: 			# $output->{type} = $type if $type && $type !~ /^\d+$/;
 3948: 			if ($VALID_OUTPUT_TYPES{$type}) {

					

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

 3949: 				$output->{type} = $type;
 3950: 				$self->_log("  OUTPUT: Inferred type from POD: $type");
 3951: 			} else {
 3952: 				$self->_log("  OUTPUT: POD return type '$type' is not a valid type, ignoring");
 3953: 			}
 3954: 		}
 3955: 	}
 3956: }
 3957: 
 3958: # --------------------------------------------------
 3959: # _extract_defaults_from_pod
 3960: #
 3961: # Purpose:    Extract default values for parameters
 3962: #             from POD documentation using multiple
 3963: #             pattern strategies.
 3964: #
 3965: # Entry:      $pod - POD string for the method.
 3966: #                    May be undef or empty.
 3967: #
 3968: # Exit:       Returns a hashref of parameter name
 3969: #             to cleaned default value. Returns an
 3970: #             empty hashref if no POD is provided
 3971: #             or no defaults are found.
 3972: #
 3973: # Side effects: None.
 3974: #
 3975: # Notes:      Three strategies are tried: (1) lines
 3976: #             containing 'Default:' or 'Defaults to:',
 3977: #             (2) lines containing 'Optional, default',
 3978: #             (3) inline $name - type, default value
 3979: #             format. Parameter names are inferred
 3980: #             by scanning backwards from the default
 3981: #             phrase to the nearest $variable.
 3982: # --------------------------------------------------
 3983: sub _extract_defaults_from_pod {
●3984 → 3991 → 4015 3984: 	my ($self, $pod) = @_;
 3985: 
 3986: 	return {} unless $pod;
 3987: 
 3988: 	my %defaults;
 3989: 
 3990: 	# Pattern 1: Default: 'value' or Defaults to: 'value'
 3991: 	while ($pod =~ /(?:Default(?:s? to)?|default(?:s? to)?)[:]\s*([^\n\r]+)/gi) {
 3992: 		my $default_text = $1;
 3993: 		my $match_pos = pos($pod);
 3994: 		$default_text =~ s/^\s+|\s+$//g;
 3995: 
 3996: 		# Look backwards in the POD to find the parameter name
 3997: 		my $context = substr($pod, 0, $match_pos);
 3998: 		my @param_matches = ($context =~ /\$(\w+)/g);
 3999: 		my $param = $param_matches[-1] if @param_matches;  # Last parameter before default
 4000: 
 4001: 		if ($param) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4002: 			# Always clean the default value - let _clean_default_value handle everything
 4003: 			if ($default_text =~ /(\w+)\s*=\s*(.+)$/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4004: 				# Has explicit param = value format in the default text
 4005: 				my ($p, $value) = ($1, $2);
 4006: 				$defaults{$p} = $self->_clean_default_value($value);
 4007: 			} else {
 4008: 				# Just a value, associate with the found param
 4009: 				$defaults{$param} = $self->_clean_default_value($default_text, 0);  # NOT from code
 4010: 			}
 4011: 		}
 4012: 	}
 4013: 
 4014: 	# Pattern 2: Optional, default 'value'
●4015 → 4015 → 4030 4015: 	while ($pod =~ /Optional(?:,)?\s+(?:default|value)\s*[:=]?\s*([^\n\r,;]+)/gi) {
 4016: 		my $default_text = $1;
 4017: 		my $match_pos = pos($pod);
 4018: 		$default_text =~ s/^\s+|\s+$//g;
 4019: 
 4020: 		# Look backwards for parameter name
 4021: 		my $context = substr($pod, 0, $match_pos);
 4022: 		my @param_matches = ($context =~ /\$(\w+)/g);
 4023: 		if (@param_matches) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4024: 			my $param = $param_matches[-1];  # Last parameter before the default
 4025: 			$defaults{$param} = $self->_clean_default_value($default_text, 0);
 4026: 		}
 4027: 	}
 4028: 
 4029: 	# Pattern 3: In parameter descriptions: $param - type, default 'value'
●4030 → 4030 → 4035 4030: 	while ($pod =~ /\$(\w+)\s*-\s*\w+(?:\([^)]*\))?[,\s]+default\s+['"]?([^'",\n]+)['"]?/gi) {
 4031: 		my ($param, $value) = ($1, $2);
 4032: 		$defaults{$param} = $self->_clean_default_value($value, 0);
 4033: 	}
 4034: 
 4035: 	return \%defaults;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 4036: }
 4037: 
 4038: # --------------------------------------------------
 4039: # _analyze_output_from_code
 4040: #
 4041: # Purpose:    Analyse return statements in a method
 4042: #             body to infer the output type by
 4043: #             counting and classifying each return
 4044: #             expression.
 4045: #
 4046: # Entry:      $output      - hashref to populate
 4047: #                            (modified in place).
 4048: #             $code        - method body source string.
 4049: #             $method_name - method name string.
 4050: #
 4051: # Exit:       Returns nothing. Modifies $output
 4052: #             in place.
 4053: #
 4054: # Side effects: Logs detections to stdout when
 4055: #               verbose is set.
 4056: # --------------------------------------------------
 4057: sub _analyze_output_from_code
 4058: {
●4059 → 4061 → 0 4059: 	my ($self, $output, $code, $method_name) = @_;
 4060: 
 4061: 	if ($code) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4062: 		# Early boolean detection - check for consistent 1/0 returns
 4063: 		my @all_returns = $code =~ /return\s+([^;]+);/g;
 4064: 		if (@all_returns) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4065: 			my $boolean_count = 0;
 4066: 			my $total_count = scalar(@all_returns);
 4067: 
 4068: 			foreach my $ret (@all_returns) {
 4069: 				$ret =~ s/^\s+|\s+$//g;
 4070: 				# Match 0 or 1, even with conditions
 4071: 				$boolean_count++ if ($ret =~ /^(?:0|1)(?:\s|$)/);
 4072: 			}
 4073: 
 4074: 			# If most returns are 0 or 1, strongly suggest boolean
 4075: 			if ($boolean_count >= 2 && $boolean_count >= $total_count * 0.8) {

  Mutants (Total: 4, Killed: 4, Survived: 0)
 4076: 				unless ($output->{type}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4077: 					$output->{type} = 'boolean';
 4078: 					$self->_log("  OUTPUT: Early detection - $boolean_count/$total_count returns are 0/1, setting boolean");
 4079: 				}
 4080: 			}
 4081: 		}
 4082: 
 4083: 		my @return_statements;
 4084: 
 4085: 		if ($code =~ /return\s+bless\s*\{[^}]*\}\s*,\s*['"]?(\w+)['"]?/s) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4086: 			# Detect blessed refs
 4087: 			$output->{type} = 'object';
 4088: 			if($method_name eq 'new') {

					

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

 4089: 				# If we found the new() method, the object we're returning should be a sensible one
 4090: 				if($self->{_document} && (my $package_stmt = $self->{_document}->find_first('PPI::Statement::Package'))) {

					

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

 4091: 					$output->{isa} = $package_stmt->namespace();
 4092: 					$self->{_package_name} //= $output->{isa};
 4093: 				}
 4094: 			} else {
 4095: 				$output->{isa} = $1;
 4096: 			}
 4097: 			$self->_log("  OUTPUT: Bless found, inferring type from code is $output->{isa}");
 4098: 		} elsif ($code =~ /return\s+bless/s) {
 4099: 			$output->{type} = 'object';
 4100: 			if($method_name eq 'new') {

					

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

 4101: 				$output->{isa} = $self->_extract_package_name();
 4102: 				$self->_log("  OUTPUT: Bless found, inferring type from code is $output->{isa}");
 4103: 			} else {
 4104: 				$self->_log('  OUTPUT: Bless found, inferring type from code is object');
 4105: 			}
 4106: 		} elsif ($code =~ /return\s*\(\s*[^)]+\s*,\s*[^)]+\s*\)\s*;/) {
 4107: 			# Detect array context returns - must end with semicolon to be actual return
 4108: 			$output->{type} = 'array';	# Not arrayref - actual array
 4109: 			$self->_log('  OUTPUT: Found array contect return');
 4110: 		} elsif ($code =~ /return\s+bless[^,]+,\s*__PACKAGE__/) {
 4111: 			# Detect: bless {}, __PACKAGE__
 4112: 			$output->{type} = 'object';
 4113: 			# Get package name from the extractor's stored document
 4114: 			if ($self->{_document}) {

					

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

 4115: 				my $pkg = $self->{_document}->find_first('PPI::Statement::Package');
 4116: 				$output->{isa} = $pkg ? $pkg->namespace : 'UNKNOWN';
 4117: 				$self->_log('  OUTPUT: Object blessed into __PACKAGE__: ' . ($output->{isa} || 'UNKNOWN'));
 4118: 				$self->{_package_name} //= $output->{isa};
 4119: 			}
 4120: 		} elsif ($code =~ /return\s*\(([^)]+)\)/) {
 4121: 			my $content = $1;
 4122: 			if ($content =~ /,/) {	# Has comma = multiple values

					

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

 4123: 				$output->{type} = 'array';
 4124: 			}
 4125: 		} elsif ($code =~ /return\s+\$self\s*;/ && $code =~ /\$self\s*->\s*\{[^}]+\}\s*=/) {
 4126: 			# Returns $self for chaining
 4127: 			$output->{type} = 'object';
 4128: 			if ($self->{_document}) {

					

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

 4129: 				my $pkg = $self->{_document}->find_first('PPI::Statement::Package');
 4130: 				$output->{isa} = $pkg ? $pkg->namespace : 'UNKNOWN';
 4131: 				$self->_log('  OUTPUT: Object chained into __PACKAGE__: ' . ($output->{isa} || 'UNKNOWN'));
 4132: 				$self->{_package_name} //= $output->{isa};
 4133: 			}
 4134: 		}
 4135: 
 4136: 		# Find all return statements
 4137: 		while ($code =~ /return\s+([^;]+);/g) {
 4138: 			my $return_expr = $1;
 4139: 			push @return_statements, $return_expr;
 4140: 		}
 4141: 
 4142: 		if (@return_statements) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4143: 			$self->_log('  OUTPUT: Found ' . scalar(@return_statements) . ' return statement(s)');
 4144: 
 4145: 			# Analyze return patterns
 4146: 			my %return_types;
 4147: 
 4148: 			if($output->{'type'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4149: 				$return_types{$output->{'type'}} += 3;	# Add weighting to what's already been found
 4150: 			}
 4151: 			my $min;
 4152: 			foreach my $ret (@return_statements) {
 4153: 				$ret =~ s/^\s+|\s+$//g;
 4154: 
 4155: 				# Literal values
 4156: 				if ($ret eq '1' || $ret eq '0') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4157: 					$return_types{boolean}++;
 4158: 				} elsif ($ret =~ /^['"]/) {
 4159: 					$return_types{string}++;
 4160: 				} elsif ($ret =~ /^-?\d+$/) {
 4161: 					$return_types{integer}++;
 4162: 				} elsif ($ret =~ /^-?\d+\.\d+$/) {
 4163: 					$return_types{number}++;
 4164: 				} elsif ($ret eq 'undef') {
 4165: 					$return_types{undef}++;
 4166: 				} elsif ($ret =~ /^\[/) {
 4167: 				# Data structures
 4168: 					$return_types{arrayref}++;
 4169: 				} elsif ($ret =~ /^\{/) {
 4170: 					$return_types{hashref}++;
 4171: 				} elsif ($ret =~ m{
 4172: 					# Numeric expressions (heuristic, medium confidence)
 4173: 					# Don't match ->
 4174: 				    (?:
 4175: 					\+ | -\b | \* | / | %
 4176: 				      | \+\+ | --
 4177: 				    )
 4178: 				}x) {
 4179: 					$return_types{number} += 2;
 4180: 				} elsif ($ret =~ /\|\|\s*\d+\b/) {
 4181: 					# Logical-or fallback with numeric literal (e.g. $x || 200)
 4182: 					$return_types{integer} += 2;
 4183: 					$self->_log("  OUTPUT: Numeric fallback expression detected");
 4184: 				} elsif($ret =~ /^length[\s\(]/) {
 4185: 					$return_types{integer}++;
 4186: 					$min = 0;
 4187: 				} elsif($ret =~ /^pos[\s\(]/) {
 4188: 					$return_types{integer}++;
 4189: 					$min = 0;
 4190: 				} elsif($ret =~ /^index[\s\(]/) {
 4191: 					$return_types{integer}++;
 4192: 					$min = -1;
 4193: 				} elsif($ret =~ /^rindex[\s\(]/) {
 4194: 					$return_types{integer}++;
 4195: 					$min = -1;
 4196: 				} elsif($ret =~ /^ord[\s\(]/) {
 4197: 					$return_types{integer}++;
 4198: 				} elsif ($ret =~ /=/ && $ret =~ /\$\w+/) {
 4199: 					# Assignment returning a value (e.g. $self->{status} = $status)
 4200: 					# If assignment involves a numeric literal or variable, assume numeric intent
 4201: 					if ($ret =~ /\b\d+\b/) {

					

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

 4202: 						$return_types{integer} += 2;
 4203: 						$self->_log("  OUTPUT: Assignment with numeric value detected");
 4204: 					} else {
 4205: 						$return_types{scalar}++;
 4206: 					}
 4207: 				}
 4208: 				# Variables/expressions
 4209: 				elsif ($ret =~ /\$\w+/) {
 4210: 					if ($ret =~ /\\\@/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4211: 						$return_types{arrayref}++;
 4212: 					} elsif ($ret =~ /\\\%/) {
 4213: 						$return_types{hashref}++;
 4214: 					} elsif ($ret =~ /bless/) {
 4215: 						$return_types{object} += 2;	# Heigher weight
 4216: 					} elsif ($ret =~ /^\{[^}]*\}$/) {
 4217: 						$return_types{hashref}++;
 4218: 					} elsif ($ret =~ /^\[[^\]]*\]$/) {
 4219: 						$return_types{arrayref}++;
 4220: 					} else {
 4221: 						$return_types{scalar}++;
 4222: 					}
 4223: 				}
 4224: 			}
 4225: 
 4226: 			# Determine most common return type
 4227: 			if (keys %return_types) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4228: 				my ($most_common) = sort { $return_types{$b} <=> $return_types{$a} } keys %return_types;
 4229: 				# Prefer integer over scalar if numeric returns dominate
 4230: 				if ($return_types{integer} && (!$return_types{string})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4231: 					if (!$output->{type} || $output->{type} eq 'scalar') {

					

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

 4232: 						$output->{type} = 'integer';
 4233: 						$self->_log("  OUTPUT: Numeric returns dominate, forcing integer");
 4234: 						$output->{_type_confidence} ||= 'low';
 4235: 						if(defined($min)) {

					

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

 4236: 							$output->{min} = $min;
 4237: 						}
 4238: 					}
 4239: 				}
 4240: 				unless ($output->{type}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4241: 					$output->{type} = $most_common;
 4242: 
 4243: 					# Assign confidence for inferred numeric expressions
 4244: 					if ($most_common eq 'number') {

					

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

 4245: 						$output->{_type_confidence} ||= 'medium';
 4246: 						if(defined($min)) {

					

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

 4247: 							$output->{min} = $min;
 4248: 						}
 4249: 					}
 4250: 
 4251: 					$self->_log("  OUTPUT: Inferred type from code: $most_common");
 4252: 				}
 4253: 			}
 4254: 
 4255: 			# Check for consistent single value returns
 4256: 			if (@return_statements == 1 && $return_statements[0] eq '1') {

					

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

 4257: 				$output->{value} = 1;
 4258: 				$output->{type} = 'boolean' if !$output->{type} || $output->{type} eq 'scalar';
 4259: 				$self->_log("  OUTPUT: Type already set to '$output->{type}', overriding with boolean") if($output->{'type'});
 4260: 			}
 4261: 		} else {
 4262: 			# No explicit return - might return nothing or implicit undef
 4263: 			$self->_log("  OUTPUT: No explicit return statement found");
 4264: 		}
 4265: 	}
 4266: }
 4267: 
 4268: # --------------------------------------------------
 4269: # _enhance_boolean_detection
 4270: #
 4271: # Purpose:    Apply additional boolean-specific
 4272: #             detection heuristics using a weighted
 4273: #             scoring system, to override weak
 4274: #             type assignments when there is strong
 4275: #             evidence of a boolean return.
 4276: #
 4277: # Entry:      $output      - output hashref
 4278: #                            (modified in place).
 4279: #             $pod         - POD string.
 4280: #             $code        - method body source string.
 4281: #             $method_name - method name string.
 4282: #
 4283: # Exit:       Returns nothing. Modifies $output
 4284: #             in place, setting type to 'boolean'
 4285: #             if the score reaches
 4286: #             $BOOLEAN_SCORE_THRESHOLD.
 4287: #
 4288: # Side effects: Logs scoring details to stdout when
 4289: #               verbose is set.
 4290: #
 4291: # Notes:      Only fires when output type is
 4292: #             not yet set or is 'unknown'. Does not
 4293: #             override explicitly set types.
 4294: # --------------------------------------------------
 4295: sub _enhance_boolean_detection {
●4296 → 4303 → 4321 4296: 	my ($self, $output, $pod, $code, $method_name) = @_;
 4297: 
 4298: 	my $boolean_score = 0;	# Track evidence for boolean return
 4299: 
 4300: 	return unless !$output->{type} || $output->{type} eq 'unknown';
 4301: 
 4302: 	# Look for stronger boolean indicators
 4303: 	if ($pod && !$output->{type}) {

					

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

 4304: 		# Common boolean return patterns in POD
 4305: 		if ($pod =~ /returns?\s+(true|false|true|false|1|0)\s+(?:on|for|upon)\s+(success|failure|error|valid|invalid)/i) {

					

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

 4306: 			$boolean_score += 30;
 4307: 			$self->_log('  OUTPUT: Strong boolean indicator in POD (+30)');
 4308: 		}
 4309: 
 4310: 		# Check for method names that suggest boolean returns
 4311: 		if ($pod =~ /(?:method|sub)\s+(\w+)/) {

					

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

 4312: 			my $inferred_method_name = $1;
 4313: 			if ($inferred_method_name =~ /^(is_|has_|can_|should_|contains_|exists_)/) {

					

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

 4314: 				$boolean_score += 20;
 4315: 				$self->_log("  OUTPUT: Inferred method name '$inferred_method_name' suggests boolean return (+20)");
 4316: 			}
 4317: 		}
 4318: 	}
 4319: 
 4320: 	# Analyze code for boolean patterns
●4321 → 4321 → 4349 4321: 	if ($code) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4322: 		# Count boolean return idioms
 4323: 		my $true_returns = () = $code =~ /return\s+1\s*;/g;
 4324: 		my $false_returns = () = $code =~ /return\s+0\s*;/g;
 4325: 
 4326: 		if ($true_returns + $false_returns >= 2) {

					

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

 4327: 			$boolean_score += 40;
 4328: 			$self->_log('  OUTPUT: Multiple 1/0 returns suggest boolean (+40)');
 4329: 		} elsif ($true_returns + $false_returns == 1) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4330: 			$boolean_score += 10;
 4331: 			$self->_log('  OUTPUT: Single 1/0 return (+10)');
 4332: 		}
 4333: 
 4334: 		# Ternary operators that return booleans
 4335: 		if ($code =~ /return\s+(?:\w+\s*[!=]=\s*\w+|\w+\s*>\s*\w+|\w+\s*<\s*\w+)\s*\?\s*(?:1|0)\s*:\s*(?:1|0)/) {

					

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

 4336: 			$boolean_score += 25;
 4337: 			$self->_log('  OUTPUT: Ternary with 1/0 suggests boolean (+25)');
 4338: 		}
 4339: 
 4340: 		# Check for common boolean method patterns
 4341: 		if ($code =~ /return\s+[!\$\@\%]/) {

					

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

 4342: 			# Returns negation or existence check
 4343: 			$boolean_score += 15;
 4344: 			$self->_log('  OUTPUT: Returns negation/existence check (+15)');
 4345: 		}
 4346: 	}
 4347: 
 4348: 	# Check method name for boolean indicators
●4349 → 4349 → 4362 4349: 	if ($method_name) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4350: 		if ($method_name =~ /^(is_|has_|can_|should_|contains_|exists_|check_|verify_|validate_)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4351: 			$boolean_score += 25;
 4352: 			$self->_log("  OUTPUT: Method name '$method_name' suggests boolean return (+25)");
 4353: 		}
 4354: 		if ($method_name =~ /_ok$/) {

					

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

 4355: 			$boolean_score += 30;
 4356: 			$self->_log("  OUTPUT: Method name '$method_name' ends with '_ok' (+30)");
 4357: 		}
 4358: 	}
 4359: 
 4360: 	# Apply boolean type if we have strong evidence
 4361: 	# Override weak type assignments (like 'array' from false positive)
●4362 → 4362 → 0 4362: 	if($boolean_score >= $BOOLEAN_SCORE_THRESHOLD) {

					

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

 4363: 		if (!$output->{type} || $output->{type} eq 'scalar' || $output->{type} eq 'array' || $output->{type} eq 'undef') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4364: 			my $old_type = $output->{type} || 'none';
 4365: 			$output->{type} = 'boolean';
 4366: 			$self->_log("  OUTPUT: Boolean score $boolean_score >= $BOOLEAN_SCORE_THRESHOLD, setting type to boolean (was: $old_type)");
 4367: 		}
 4368: 	}
 4369: }
 4370: 
 4371: # --------------------------------------------------
 4372: # _detect_list_context
 4373: #
 4374: # Purpose:    Detect methods that return different
 4375: #             values depending on calling context
 4376: #             via wantarray, and methods that
 4377: #             return explicit lists.
 4378: #
 4379: # Entry:      $output - output hashref (modified
 4380: #                       in place).
 4381: #             $code   - method body source string.
 4382: #
 4383: # Exit:       Returns nothing. Modifies $output
 4384: #             in place, setting _context_aware,
 4385: #             _list_context, _scalar_context,
 4386: #             _list_return, and/or type keys.
 4387: #
 4388: # Side effects: Logs detections to stdout when
 4389: #               verbose is set.
 4390: # --------------------------------------------------
 4391: sub _detect_list_context {
●4392 → 4396 → 4434 4392: 	my ($self, $output, $code) = @_;
 4393: 	return unless $code;
 4394: 
 4395: 	# Check for wantarray usage
 4396: 	if ($code =~ /wantarray/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4397: 		$output->{_context_aware} = 1;
 4398: 		$self->_log('  OUTPUT: Method uses wantarray - context sensitive');
 4399: 
 4400: 		# Debug: show what we're matching against
 4401: 		if ($code =~ /(wantarray[^;]+;)/s) {

					

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

 4402: 			$self->_log("  DEBUG wantarray line: $1");
 4403: 		}
 4404: 
 4405: 		if ($code =~ /wantarray\s*\?\s*\(([^)]+)\)\s*:\s*([^;]+)/s) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4406: 			# Pattern 1: wantarray ? (list, items) : scalar_value (with parens)
 4407: 			my ($list_return, $scalar_return) = ($1, $2);
 4408: 			$self->_log("  DEBUG list (with parens): [$list_return], scalar: [$scalar_return]");
 4409: 
 4410: 			$output->{_list_context} = $self->_infer_type_from_expression($list_return);
 4411: 			$output->{_scalar_context} = $self->_infer_type_from_expression($scalar_return);
 4412: 			$self->_log('  OUTPUT: Detected context-dependent returns (parenthesized)');
 4413: 		} elsif ($code =~ /wantarray\s*\?\s*([^:]+?)\s*:\s*([^;]+)/s) {
 4414: 			# Pattern 2: wantarray ? @array : scalar (no parens around list)
 4415: 			my ($list_return, $scalar_return) = ($1, $2);
 4416: 			# Clean up
 4417: 			$list_return =~ s/^\s+|\s+$//g;
 4418: 			$scalar_return =~ s/^\s+|\s+$//g;
 4419: 
 4420: 			$self->_log("  DEBUG list (no parens): [$list_return], scalar: [$scalar_return]");
 4421: 
 4422: 			$output->{_list_context} = $self->_infer_type_from_expression($list_return);
 4423: 			$output->{_scalar_context} = $self->_infer_type_from_expression($scalar_return);
 4424: 			$self->_log('  OUTPUT: Detected context-dependent returns (non-parenthesized)');
 4425: 		} elsif ($code =~ /return[^;]*unless\s+wantarray.*?return\s*\(([^)]+)\)/s) {
 4426: 			# Pattern 3: return unless wantarray; return (list);
 4427: 			$output->{_list_context} = { type => 'array' };
 4428: 			$self->_log('  OUTPUT: Detected list context return after wantarray check');
 4429: 		}
 4430: 	}
 4431: 
 4432: 	# Detect explicit list returns (multiple values in parentheses)
 4433: 	# Avoid false positives from function calls
●4434 → 4434 → 0 4434: 	if ($code =~ /return\s*\(\s*([^)]+)\s*\)\s*;/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4435: 		my $content = $1;
 4436: 
 4437: 		# Count commas outside of nested structures, jumping over each
 4438: 		# balanced bracketed block in one step via extract_bracketed
 4439: 		require Text::Balanced;
 4440: 		my $comma_count = 0;
 4441: 		my $rest = $content;
 4442: 		while (length $rest) {
 4443: 			if (substr($rest, 0, 1) =~ /[(\[{]/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4444: 				my $extracted = Text::Balanced::extract_bracketed($rest, '(){}[]');
 4445: 				last unless defined $extracted;	# Unbalanced brackets
 4446: 				next;
 4447: 			}
 4448: 			$comma_count++ if substr($rest, 0, 1) eq ',';
 4449: 			$rest = substr($rest, 1);
 4450: 		}
 4451: 
 4452: 		if ($comma_count > 0 && $content !~ /\b(?:bless|new)\b/) {

  Mutants (Total: 4, Killed: 4, Survived: 0)
 4453: 			# Multiple values returned
 4454: 			unless ($output->{type} && $output->{type} eq 'boolean') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4455: 				$output->{type} = 'array';
 4456: 				$output->{_list_return} = $comma_count + 1;
 4457: 				$self->_log('  OUTPUT: Returns list of ' . ($comma_count + 1) . ' values');
 4458: 			}
 4459: 		}
 4460: 	}
 4461: }
 4462: 
 4463: # --------------------------------------------------
 4464: # _detect_void_context
 4465: #
 4466: # Purpose:    Detect methods that return nothing
 4467: #             meaningful (void context), methods
 4468: #             that always return 1 as a success
 4469: #             indicator, and methods whose name
 4470: #             suggests void context (setters,
 4471: #             mutators, loggers).
 4472: #
 4473: # Entry:      $output      - output hashref
 4474: #                            (modified in place).
 4475: #             $code        - method body source string.
 4476: #             $method_name - method name string.
 4477: #
 4478: # Exit:       Returns nothing. Modifies $output
 4479: #             in place, setting _void_context,
 4480: #             _success_indicator, and/or type.
 4481: #
 4482: # Side effects: Logs detections to stdout when
 4483: #               verbose is set.
 4484: # --------------------------------------------------
 4485: sub _detect_void_context {
●4486 → 4500 → 4509 4486: 	my ($self, $output, $code, $method_name) = @_;
 4487: 	return unless $code;
 4488: 
 4489: 	$self->_log("  DEBUG _detect_void_context called for $method_name");
 4490: 
 4491: 	# Methods that typically don't return meaningful values
 4492: 	my $void_patterns = {
 4493: 		'setter' => qr/^set_\w+$/,
 4494: 		'mutator' => qr/^(?:add|remove|delete|clear|reset|update)_/,
 4495: 		'logger' => qr/^(?:log|debug|warn|error|info)$/,
 4496: 		'printer' => qr/^(?:print|say|dump)_/,
 4497: 	};
 4498: 
 4499: 	# Check if method name suggests void context
 4500: 	foreach my $type (keys %$void_patterns) {
 4501: 		if ($method_name =~ $void_patterns->{$type}) {

					

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

 4502: 			$output->{_void_context_hint} = $type;
 4503: 			$self->_log("  OUTPUT: Method name suggests $type (typically void context)");
 4504: 			last;
 4505: 		}
 4506: 	}
 4507: 
 4508: 	# Analyze return statements
●4509 → 4518 → 4533 4509: 	my @returns = $code =~ /return\s*([^;]*);/g;
 4510: 
 4511: 	$self->_log('  DEBUG Found ' . scalar(@returns) . ' return statements');
 4512: 
 4513: 	# Count different return patterns
 4514: 	my $no_value_returns = 0;
 4515: 	my $true_returns = 0;
 4516: 	my $self_returns = 0;
 4517: 
 4518: 	foreach my $ret (@returns) {
 4519: 		$ret =~ s/^\s+|\s+$//g;
 4520: 		$self->_log("  DEBUG return value: [$ret]");
 4521: 		$no_value_returns++ if $ret eq '';
 4522: 		$no_value_returns++ if($ret =~ /^(if|unless)\s/);
 4523: 		$true_returns++ if $ret eq '1';
 4524: 		$self_returns++ if $ret eq '$self';
 4525: 		if ($ret =~ /\?\s*1\s*:\s*0\b/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4526: 			# Strong boolean signal: ternary returning 1/0
 4527: 			$true_returns++;
 4528: 			# $self->_log("  OUTPUT: Ternary 1:0 return detected, treating as boolean (+40)");
 4529: 			$self->_log('  OUTPUT: Ternary 1:0 return detected, treating as boolean');
 4530: 		}
 4531: 	}
 4532: 
●4533 → 4538 → 0 4533: 	my $total_returns = scalar(@returns);
 4534: 
 4535: 	$self->_log("  DEBUG no_value=$no_value_returns, true=$true_returns, self=$self_returns, total=$total_returns");
 4536: 
 4537: 	# Void context indicators
 4538: 	if ($no_value_returns > 0 && $no_value_returns == $total_returns) {

  Mutants (Total: 5, Killed: 5, Survived: 0)
 4539: 		$output->{_void_context} = 1;
 4540: 		$output->{type} = 'void';  # This should override any previous type
 4541: 		$self->_log('  OUTPUT: All returns are empty - void context method');
 4542: 	} elsif ($true_returns > 0 && $true_returns == $total_returns && $total_returns >= 1) {

  Mutants (Total: 7, Killed: 7, Survived: 0)
 4543: 		# Methods that always return true (success indicator)
 4544: 		$output->{_success_indicator} = 1;
 4545: 		# Don't override type if already set to boolean
 4546: 		unless ($output->{type} && $output->{type} eq 'boolean') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4547: 			$output->{type} = 'boolean';
 4548: 		}
 4549: 		$self->_log('  OUTPUT: Always returns 1 - success indicator pattern');
 4550: 	}
 4551: }
 4552: 
 4553: # --------------------------------------------------
 4554: # _detect_chaining_pattern
 4555: #
 4556: # Purpose:    Detect methods that return $self for
 4557: #             fluent interface chaining, by counting
 4558: #             the proportion of return statements
 4559: #             that return $self.
 4560: #
 4561: # Entry:      $output - output hashref (modified
 4562: #                       in place).
 4563: #             $code   - method body source string.
 4564: #
 4565: # Exit:       Returns nothing. Modifies $output
 4566: #             in place, setting type to 'object',
 4567: #             _returns_self to 1, and isa to the
 4568: #             current package name when the
 4569: #             proportion of $self returns is >= 0.8.
 4570: #
 4571: # Side effects: Logs detection to stdout when
 4572: #               verbose is set.
 4573: # --------------------------------------------------
 4574: sub _detect_chaining_pattern {
●4575 → 4582 → 4590 4575: 	my ($self, $output, $code) = @_;
 4576: 	return unless $code;
 4577: 
 4578: 	# Count returns of $self
 4579: 	my $self_returns = 0;
 4580: 	my $total_returns = 0;
 4581: 
 4582: 	while ($code =~ /return\s+([^;]+);/g) {
 4583: 		my $ret = $1;
 4584: 		$ret =~ s/^\s+|\s+$//g;
 4585: 		$total_returns++;
 4586: 		$self_returns++ if $ret eq '$self';
 4587: 	}
 4588: 
 4589: 	# If most/all returns are $self, it's a chaining method
●4590 → 4590 → 0 4590: 	if ($self_returns > 0 && $total_returns > 0) {

  Mutants (Total: 4, Killed: 4, Survived: 0)
 4591: 		my $ratio = $self_returns / $total_returns;
 4592: 
 4593: 		if ($ratio >= 0.8) {

					

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

 4594: 			$output->{type} = 'object';
 4595: 			$output->{_returns_self} = 1;
 4596: 
 4597: 			# Get the class name
 4598: 			if ($self->{_document}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4599: 				my $pkg = $self->{_document}->find_first('PPI::Statement::Package');
 4600: 				$output->{isa} = $pkg ? $pkg->namespace : 'UNKNOWN';
 4601: 				$self->{_package_name} //= $output->{isa};
 4602: 			}
 4603: 
 4604: 			$self->_log("  OUTPUT: Chainable method - returns \$self ($self_returns/$total_returns returns)");
 4605: 		}
 4606: 	}
 4607: }
 4608: 
 4609: # --------------------------------------------------
 4610: # _detect_error_conventions
 4611: #
 4612: # Purpose:    Analyse how a method signals errors
 4613: #             by detecting patterns such as
 4614: #             'return undef if', implicit bare
 4615: #             returns, empty list returns, 0/1
 4616: #             boolean error patterns, and eval
 4617: #             exception handling.
 4618: #
 4619: # Entry:      $output - output hashref (modified
 4620: #                       in place).
 4621: #             $code   - method body source string.
 4622: #
 4623: # Exit:       Returns nothing. Modifies $output
 4624: #             in place, setting _error_handling,
 4625: #             _error_return, and
 4626: #             _success_failure_pattern keys.
 4627: #
 4628: # Side effects: Logs detections to stdout when
 4629: #               verbose is set.
 4630: # --------------------------------------------------
 4631: sub _detect_error_conventions {
●4632 → 4641 → 4647 4632: 	my ($self, $output, $code) = @_;
 4633: 
 4634: 	return unless $code;
 4635: 
 4636: 	$self->_log('  DEBUG _detect_error_conventions called');
 4637: 
 4638: 	my %error_patterns;
 4639: 
 4640: 	# Pattern 1: return undef if/unless condition
 4641: 	while ($code =~ /return\s+undef\s+(?:if|unless)\s+([^;]+);/g) {
 4642: 		push @{$error_patterns{undef_on_error}}, $1;
 4643: 		$self->_log("  DEBUG Found 'return undef' pattern");
 4644: 	}
 4645: 
 4646: 	# Pattern 2: return if/unless (implicit undef)
●4647 → 4647 → 4653 4647: 	while ($code =~ /return\s+(?:if|unless)\s+([^;]+);/g) {
 4648: 		push @{$error_patterns{implicit_undef}}, $1;
 4649: 		$self->_log("  DEBUG Found implicit undef pattern");
 4650: 	}
 4651: 
 4652: 	# Pattern 3: return () - matches with or without conditions
●4653 → 4653 → 4659 4653: 	if ($code =~ /return\s*\(\s*\)\s*(?:if|unless|;)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4654: 		$error_patterns{empty_list} = 1;
 4655: 		$self->_log("  DEBUG Found empty list return");
 4656: 	}
 4657: 
 4658: 	# Pattern 4: return 0/1 pattern (indicates boolean with error handling)
●4659 → 4662 → 4670 4659: 	my $zero_returns = 0;
 4660: 	my $one_returns = 0;
 4661: 	# Match "return 0" or "return 1" followed by anything (condition or semicolon)
 4662: 	while ($code =~ /return\s+(0|1)\s*(?:;|if|unless)/g) {
 4663: 		if ($1 eq '0') {

					

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

 4664: 			$zero_returns++;
 4665: 		} else {
 4666: 			$one_returns++;
 4667: 		}
 4668: 	}
 4669: 
●4670 → 4670 → 4676 4670: 	if ($zero_returns > 0 && $one_returns > 0) {

  Mutants (Total: 4, Killed: 4, Survived: 0)
 4671: 		$error_patterns{zero_on_error} = 1;
 4672: 		$self->_log("  DEBUG Found 0/1 return pattern ($zero_returns zeros, $one_returns ones)");
 4673: 	}
 4674: 
 4675: 	# Pattern 5: Exception handling with eval
●4676 → 4676 → 4685 4676: 	if ($code =~ /eval\s*\{/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4677: 		# Check if there's error handling after eval
 4678: 		if ($code =~ /eval\s*\{.*?\}[^}]*(?:if\s*\(\s*\$\@|catch|return\s+undef)/s) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4679: 			$error_patterns{exception_handling} = 1;
 4680: 			$self->_log('  DEBUG Found exception handling with eval');
 4681: 		}
 4682: 	}
 4683: 
 4684: 	# Detect success/failure return pattern
●4685 → 4689 → 4695 4685: 	my @all_returns = $code =~ /return\s+([^;]+);/g;
 4686: 	my $has_undef = grep { /^\s*undef\s*(?:if|unless|$)/ } @all_returns;
 4687: 	my $has_value = grep { !/^\s*undef\s*$/ && !/^\s*$/ } @all_returns;
 4688: 
 4689: 	if ($has_undef && $has_value && scalar(@all_returns) >= 2) {

  Mutants (Total: 4, Killed: 4, Survived: 0)
 4690: 		$output->{_success_failure_pattern} = 1;
 4691: 		$self->_log("  OUTPUT: Uses success/failure return pattern");
 4692: 	}
 4693: 
 4694: 	# Store error conventions in output
●4695 → 4695 → 0 4695: 	if(scalar(keys %error_patterns)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4696: 		$output->{_error_handling} = \%error_patterns;
 4697: 
 4698: 		# Determine primary error convention
 4699: 		if ($error_patterns{undef_on_error}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4700: 			$output->{_error_return} = 'undef';
 4701: 			$self->_log("  OUTPUT: Returns undef on error");
 4702: 		} elsif ($error_patterns{implicit_undef}) {
 4703: 			$output->{_error_return} = 'undef';
 4704: 			$self->_log("  OUTPUT: Returns implicit undef on error");
 4705: 		} elsif ($error_patterns{empty_list}) {
 4706: 			$output->{_error_return} = 'empty_list';
 4707: 			$self->_log("  OUTPUT: Returns empty list on error");
 4708: 		} elsif ($error_patterns{zero_on_error}) {
 4709: 			$output->{_error_return} = 'false';
 4710: 			$self->_log("  OUTPUT: Returns 0/false on error");
 4711: 		}
 4712: 
 4713: 		if ($error_patterns{exception_handling}) {

					

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

 4714: 			$self->_log("  OUTPUT: Has exception handling");
 4715: 		}
 4716: 	} else {
 4717: 		delete $output->{_error_handling};
 4718: 	}
 4719: }
 4720: 
 4721: # --------------------------------------------------
 4722: # _infer_type_from_expression
 4723: #
 4724: # Purpose:    Infer the data type of a return
 4725: #             expression string by matching it
 4726: #             against common Perl literal and
 4727: #             variable patterns.
 4728: #
 4729: # Entry:      $expr - return expression string,
 4730: #                     trimmed of leading and
 4731: #                     trailing whitespace.
 4732: #                     May be undef.
 4733: #
 4734: # Exit:       Returns a type hashref of the form
 4735: #             { type => '...' } and optionally
 4736: #             { min => N }. Defaults to
 4737: #             { type => 'scalar' } when no
 4738: #             pattern matches.
 4739: #
 4740: # Side effects: None.
 4741: # --------------------------------------------------
 4742: sub _infer_type_from_expression {
●4743 → 4750 → 4770 4743: 	my ($self, $expr) = @_;
 4744: 
 4745: 	return { type => 'scalar' } unless defined $expr;
 4746: 
 4747: 	$expr =~ s/^\s+|\s+$//g;
 4748: 
 4749: 	# Check for multiple comma-separated values (indicates array/list)
 4750: 	if ($expr =~ /,/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4751: 		require Text::Balanced;
 4752: 		my $comma_count = 0;
 4753: 		my $rest = $expr;
 4754: 		while (length $rest) {
 4755: 			if (substr($rest, 0, 1) =~ /[(\[{]/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4756: 				my $extracted = Text::Balanced::extract_bracketed($rest, '(){}[]');
 4757: 				last unless defined $extracted;	# Unbalanced brackets
 4758: 				next;
 4759: 			}
 4760: 			$comma_count++ if substr($rest, 0, 1) eq ',';
 4761: 			$rest = substr($rest, 1);
 4762: 		}
 4763: 
 4764: 		if ($comma_count > 0) {

  Mutants (Total: 4, Killed: 4, Survived: 0)
 4765: 			return { type => 'array' };
 4766: 		}
 4767: 	}
 4768: 
 4769: 	# Check for @ prefix (array)
●4770 → 4770 → 4775 4770: 	if ($expr =~ /^\@\w+/ || $expr =~ /^qw\(/ || $expr =~ /^\@\{/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4771: 		return { type => 'array' };
 4772: 	}
 4773: 
 4774: 	# Check for scalar() function - returns count
●4775 → 4775 → 4780 4775: 	if ($expr =~ /scalar\s*\(/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4776: 		return { type => 'integer', min => 0 };
 4777: 	}
 4778: 
 4779: 	# Check for array reference
●4780 → 4780 → 4785 4780: 	if ($expr =~ /^\[/ || $expr =~ /^\\\@/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4781: 		return { type => 'arrayref' };
 4782: 	}
 4783: 
 4784: 	# Check for hash reference
●4785 → 4785 → 4790 4785: 	if ($expr =~ /^\{/ || $expr =~ /^\\\%/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4786: 		return { type => 'hashref' };
 4787: 	}
 4788: 
 4789: 	# Check for hash
●4790 → 4790 → 4795 4790: 	if ($expr =~ /^\%\w+/ || $expr =~ /^\%\{/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4791: 		return { type => 'hash' };
 4792: 	}
 4793: 
 4794: 	# Check for strings
●4795 → 4795 → 4801 4795: 	if ($expr =~ /^['"]/ || $expr =~ /['"]$/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4796: 		return { type => 'string' };
 4797: 	}
 4798: 
 4799: 	# Check for booleans first — must come before the integer check
 4800: 	# since /^-?\d+$/ would otherwise match 0 and 1 as integers
●4801 → 4801 → 4806 4801: 	if($expr =~ /^[01]$/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4802: 		return { type => 'boolean' };
 4803: 	}
 4804: 
 4805: 	# Check for integers
●4806 → 4806 → 4810 4806: 	if($expr =~ /^-?\d+$/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4807: 		return { type => 'integer' };
 4808: 	}
 4809: 
●4810 → 4810 → 4815 4810: 	if ($expr =~ /^-?\d+\.\d+$/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4811: 		return { type => 'number' };
 4812: 	}
 4813: 
 4814: 	# Check for objects
●4815 → 4815 → 4819 4815: 	if ($expr =~ /bless/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4816: 		return { type => 'object' };
 4817: 	}
 4818: 
●4819 → 4819 → 4824 4819: 	if($expr =~ /\blength\s*\(/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4820: 		return { type => 'integer', min => 0 };
 4821: 	}
 4822: 
 4823: 	# Default to scalar
 4824: 	return { type => 'scalar' };
 4825: }
 4826: 
 4827: # --------------------------------------------------
 4828: # _detect_chaining_from_pod
 4829: #
 4830: # Purpose:    Check POD documentation for explicit
 4831: #             indications that a method is chainable
 4832: #             or part of a fluent interface.
 4833: #
 4834: # Entry:      $output - output hashref (modified
 4835: #                       in place).
 4836: #             $pod    - POD string for the method.
 4837: #
 4838: # Exit:       Returns nothing. Sets _returns_self
 4839: #             in $output if chaining keywords are
 4840: #             found.
 4841: #
 4842: # Side effects: Logs detection to stdout when
 4843: #               verbose is set.
 4844: # --------------------------------------------------
 4845: sub _detect_chaining_from_pod {
●4846 → 4850 → 0 4846: 	my ($self, $output, $pod) = @_;
 4847: 	return unless $pod;
 4848: 
 4849: 	# Look for explicit chaining documentation
 4850: 	if ($pod =~ /returns?\s+(?:\$)?self\b/i ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4851: 		$pod =~ /chainable/i ||
 4852: 		$pod =~ /fluent\s+interface/i ||
 4853: 		$pod =~ /method\s+chaining/i) {
 4854: 
 4855: 		$output->{_returns_self} = 1;
 4856: 		$self->_log("  OUTPUT: POD indicates chainable/fluent interface");
 4857: 	}
 4858: }
 4859: 
 4860: # --------------------------------------------------
 4861: # _validate_output
 4862: #
 4863: # Purpose:    Apply basic sanity checks to the
 4864: #             assembled output hashref and warn
 4865: #             about suspicious type combinations,
 4866: #             normalising clearly invalid types to
 4867: #             'string'.
 4868: #
 4869: # Entry:      $output - output hashref (modified
 4870: #                       in place).
 4871: #
 4872: # Exit:       Returns nothing. May modify type key
 4873: #             in $output. Logs warnings to stdout
 4874: #             when verbose is set.
 4875: #
 4876: # Side effects: None.
 4877: # --------------------------------------------------
 4878: sub _validate_output {
●4879 → 4882 → 4885 4879: 	my ($self, $output) = @_;
 4880: 
 4881: 	# Warn about suspicious combinations
 4882: 	if (defined $output->{type} && $output->{type} eq 'boolean' && !defined($output->{value})) {

					

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

 4883: 		$self->_log('  WARNING Boolean type without value - may want to set value: 1');
 4884: 	}
●4885 → 4885 → 4888 4885: 	if ($output->{value} && defined $output->{type} && $output->{type} ne 'boolean') {

					

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

 4886: 		$self->_log("  WARNING Value set but type is not boolean: $output->{type}");
 4887: 	}
●4888 → 4889 → 0 4888: 	my %valid_types = map { $_ => 1 } qw(string integer number boolean array arrayref hashref object void);
 4889: 	if(exists $output->{type}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4890: 		if(!$valid_types{$output->{type}}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4891: 			$self->_log("  WARNING Output value type is unknown: '$output->{type}', setting to string");
 4892: 			$output->{type} = 'string';
 4893: 		}
 4894: 	}
 4895: }
 4896: 
 4897: # --------------------------------------------------
 4898: # _parse_constraints
 4899: #
 4900: # Purpose:    Parse a constraint string extracted
 4901: #             from POD documentation and populate
 4902: #             min, max, or other constraint fields
 4903: #             in a parameter hashref.
 4904: #
 4905: # Entry:      $param      - hashref for the parameter
 4906: #                           being annotated (modified
 4907: #                           in place).
 4908: #             $constraint - the constraint string,
 4909: #                           e.g. '3-50', 'positive',
 4910: #                           '>= 0', 'min 3'.
 4911: #
 4912: # Exit:       Returns nothing. Modifies $param in
 4913: #             place by setting min and/or max keys.
 4914: #
 4915: # Side effects: Logs min/max values to stdout when
 4916: #               verbose is set.
 4917: # --------------------------------------------------
 4918: sub _parse_constraints {
●4919 → 4922 → 4962 4919: 	my ($self, $param, $constraint) = @_;
 4920: 
 4921: 	# Range: "3-50" or "1-100 chars"
 4922: 	if ($constraint =~ /(\d+)\s*-\s*(\d+)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 4923: 		$param->{min} = $1;
 4924: 		$param->{max} = $2;
 4925: 	}
 4926: 	elsif ($constraint =~ /(\d+)\s*\.\.\s*(\d+)/) {
 4927: 		# Range: 0..19
 4928: 		$param->{min} = $1;
 4929: 		$param->{max} = $2;
 4930: 	}
 4931: 	# Minimum: "min 3" or "at least 5"
 4932: 	elsif ($constraint =~ /(?:min|minimum|at least)\s*(\d+)/i) {
 4933: 		$param->{min} = $1;
 4934: 	}
 4935: 	# Maximum: "max 50" or "up to 100"
 4936: 	elsif ($constraint =~ /(?:max|maximum|up to)\s*(\d+)/i) {
 4937: 		$param->{max} = $1;
 4938: 	}
 4939: 	# Positive
 4940: 	elsif ($constraint =~ /positive/i) {
 4941: 		$param->{min} = 1 if $param->{type} && $param->{type} eq 'integer';
 4942: 		$param->{min} = 0.01 if $param->{type} && $param->{type} eq 'number';
 4943: 	}
 4944: 	# Non-negative
 4945: 	elsif ($constraint =~ /non-negative/i) {
 4946: 		$param->{min} = 0;
 4947: 	} elsif($constraint =~ /(.+)?\s(.+)/) {
 4948: 		my ($op, $val) = ($1, $2);
 4949: 		if(looks_like_number($val)) {

					

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

 4950: 			if ($op eq '<') {

					

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

 4951: 				$param->{max} = $val - 1;
 4952: 			} elsif ($op eq '<=') {
 4953: 				$param->{max} = $val;
 4954: 			} elsif ($op eq '>') {
 4955: 				$param->{min} = $val + 1;
 4956: 			} elsif ($op eq '>=') {
 4957: 				$param->{min} = $val;
 4958: 			}
 4959: 		}
 4960: 	}
 4961: 
●4962 → 4962 → 4965 4962: 	if(defined($param->{max})) {

					

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

 4963: 		$self->_log("  Set max to $param->{max}");
 4964: 	}
●4965 → 4965 → 0 4965: 	if(defined($param->{min})) {

					

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

 4966: 		$self->_log("  Set min to $param->{min}");
 4967: 	}
 4968: }
 4969: 
 4970: # --------------------------------------------------
 4971: # _analyze_code
 4972: #
 4973: # Purpose:    Analyse a method's source code using
 4974: #             pattern matching to infer parameter
 4975: #             names, types, constraints, defaults,
 4976: #             and optionality. Orchestrates all
 4977: #             per-parameter code analysis helpers.
 4978: #
 4979: # Entry:      $code   - method body source string.
 4980: #             $method - method hashref (used for
 4981: #                       constructor-specific logic
 4982: #                       when extracting parameters
 4983: #                       from @_ patterns).
 4984: #
 4985: # Exit:       Returns a hashref of parameter name
 4986: #             to parameter spec hashref, with as
 4987: #             much type and constraint information
 4988: #             as could be inferred from the code.
 4989: #
 4990: # Side effects: Logs progress and warnings to stdout
 4991: #               when verbose is set.
 4992: #
 4993: # Notes:      Analysis is capped at max_parameters
 4994: #             to prevent runaway processing on
 4995: #             pathological methods. Falls back to
 4996: #             classic @_ extraction if signature
 4997: #             extraction found no parameters.
 4998: # --------------------------------------------------
 4999: sub _analyze_code {
●5000 → 5013 → 5023 5000: 	my ($self, $code, $method) = @_;
 5001: 
 5002: 	my %params;
 5003: 
 5004: 	# Safety check - limit parameter analysis to prevent runaway processing
 5005: 	my $param_count = 0;
 5006: 
 5007: 	# Extract parameter names from various signature styles
 5008: 	$self->_extract_parameters_from_signature(\%params, $code);
 5009: 
 5010: 	# Params::Get: get_params('key', \@_) passes the param name as a string,
 5011: 	# not as a $var in the signature, so run this unconditionally as a second
 5012: 	# pass after the early-returning signature parsers have finished.
 5013: 	if($code =~ /Params::Get/) {

					

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

 5014: 		my $pos = scalar keys %params;
 5015: 		while($code =~ /get_params\s*\(\s*['"](\w+)['"]/g) {
 5016: 			my $name = $1;
 5017: 			next if $name =~ /^(self|class)$/i;
 5018: 			$params{$name} //= { _source => 'code', position => $pos++ };
 5019: 			$self->_log("  CODE: Found Params::Get parameter '$name'");
 5020: 		}
 5021: 	}
 5022: 
●5023 → 5026 → 5039 5023: 	$self->_extract_defaults_from_code(\%params, $code, $method);
 5024: 
 5025: 	# Infer types from defaults
 5026: 	foreach my $param (keys %params) {
 5027: 		if ($params{$param}{_default} && !$params{$param}{type}) {

					

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

 5028: 			my $default = $params{$param}{_default};
 5029: 			if (ref($default) eq 'HASH') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5030: 				$params{$param}{type} = 'hashref';
 5031: 				$self->_log("  CODE: $param type inferred as hashref from default");
 5032: 			} elsif (ref($default) eq 'ARRAY') {
 5033: 				$params{$param}{type} = 'arrayref';
 5034: 				$self->_log("  CODE: $param type inferred as arrayref from default");
 5035: 			}
 5036: 		}
 5037: 	}
 5038: 
●5039 → 5039 → 5054 5039: 	if($code =~ /(croak|die)\(.*\)\s+if\s*\(\s*scalar\(\@_\)\s*<\s*(\d+)\s*\)/s) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5040: 		my $required_count = $2;
 5041: 		my @param_names = sort { $params{$a}{position} <=> $params{$b}{position} } keys %params;
 5042: 		for my $i (0 .. $required_count-1) {
 5043: 			$params{$param_names[$i]}{optional} = 0;
 5044: 			$self->_log("  CODE: $param_names[$i] marked required due to croak scalar check");
 5045: 		}
 5046: 	} elsif ($code =~ /(croak|die)\(.*\)\s+if\s*\(\s*scalar\(\@_\)\s*==\s*(0)\s*\)/s) {
 5047: 		foreach my $param (keys %params) {
 5048: 			$params{$param}{optional} = 0;
 5049: 			$self->_log("  CODE: $param: all parameters are required due to 'scalar(@_) == 0' check");
 5050: 		}
 5051: 	}
 5052: 
 5053: 	# Analyze each parameter (with safety limit)
●5054 → 5054 → 5123 5054: 	foreach my $param (keys %params) {
 5055: 		if ($param_count++ > $self->{max_parameters}) {

  Mutants (Total: 4, Killed: 4, Survived: 0)
 5056: 			$self->_log("  WARNING: Max parameters ($self->{max_parameters}) exceeded, skipping remaining");
 5057: 			last;
 5058: 		}
 5059: 
 5060: 		my $p = \$params{$param};
 5061: 
 5062: 		$self->_analyze_parameter_type($p, $param, $code);
 5063: 		$self->_analyze_parameter_constraints($p, $param, $code);
 5064: 		$self->_analyze_parameter_validation($p, $param, $code);
 5065: 		$self->_analyze_advanced_types($p, $param, $code);
 5066: 
 5067: 		# Defined checks
 5068: 		if ($code =~ /defined\s*\(\s*\$$param\s*\)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5069: 			$$p->{optional} = 0;
 5070: 			$self->_log("  CODE: $param is required (defined check)");
 5071: 		}
 5072: 
 5073: 		# Determine optional/required and numeric type from code
 5074: 		if ($code =~ /\s*\$$param\s*(?:\/\/|\|\|)=/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5075: 			# e.g. $var //= 5; or $var ||= 5;
 5076: 			$$p->{optional} = 1;
 5077: 			$self->_log("  CODE: $param is optional (default value assigned in code)");
 5078: 		} elsif ($code =~ /\s*\$$param\s*(?:[\+\-\*\%]|\/(?!\/)|(?:\+\+)|(?:--)|(?:[\+\-\*\%]=|\/(?!\/)=)|\+\$|\$[+-])/ ) {
 5079: 			# Covers arithmetic usage:
 5080: 			# $x + $param, $param++, $param--, $x += $param, $x -= $param, etc.
 5081: 			$$p->{optional} = 0;
 5082: 			$$p->{type} //= 'number';
 5083: 			$self->_log("  CODE: $param is required (used in arithmetic context)");
 5084: 		} elsif ($code =~ /\$\b$param\b\s*(?:\+0|\*1)/) {
 5085: 			# Forces numeric context, e.g., "$param + 0" or "$param * 1"
 5086: 			$$p->{optional} = 0;
 5087: 			$$p->{type} //= 'number';
 5088: 			$self->_log("  CODE: $param is required (numeric context)");
 5089: 		}
 5090: 
 5091: 		# Required parameter checks (undef causes error)
 5092: 
 5093: 		# Style 1: block form
 5094: 		if ($code =~ /if\s*\(\s*!\s*defined\s*\(\s*\$$param\s*\)\s*\)\s*\{([^}]+)\}/s) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5095: 			my $block = $1;
 5096: 			if ($block =~ /\b(croak|die|confess)\b/) {

					

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

 5097: 				$$p->{optional} = 0;
 5098: 				$self->_log("  CODE: $param is required (undef causes error)");
 5099: 			}
 5100: 		}
 5101: 
 5102: 		# Style 2: postfix unless
 5103: 		if ($code =~ /\b(croak|die|confess)\b[^;]*\bunless\s+defined\s*\(\s*\$$param\s*\)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5104: 			$$p->{optional} = 0;
 5105: 			$self->_log("  CODE: $param is required (postfix undef check)");
 5106: 		}
 5107: 
 5108: 		# Exists checks for hash keys
 5109: 		if ($code =~ /exists\s*\(\s*\$$param\s*\)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5110: 			$$p->{type} = 'hashkey';
 5111: 			$self->_log("  CODE: $param is a hash key");
 5112: 		}
 5113: 
 5114: 		# Scalar context for arrays
 5115: 		if ($code =~ /scalar\s*\(\s*\@?\$$param\s*\)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5116: 			$$p->{type} = 'array';
 5117: 			$self->_log("  CODE: $param used in scalar context (array)");
 5118: 		}
 5119: 
 5120: 		$self->_extract_error_constraints($p, $param, $code);
 5121: 	}
 5122: 
 5123: 	return \%params;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 5124: }
 5125: 
 5126: # --------------------------------------------------
 5127: # _analyze_parameter_type
 5128: #
 5129: # Purpose:    Infer the type of a single parameter
 5130: #             from ref() checks, isa() calls,
 5131: #             bless patterns, array/hash operations,
 5132: #             and numeric operator usage in the
 5133: #             method body.
 5134: #
 5135: # Entry:      $p_ref - reference to the parameter
 5136: #                      hashref (modified in place
 5137: #                      via the referenced hash).
 5138: #             $param - parameter name string.
 5139: #             $code  - method body source string.
 5140: #
 5141: # Exit:       Returns nothing. Modifies the
 5142: #             referenced parameter hashref.
 5143: #
 5144: # Side effects: Logs detections to stdout when
 5145: #               verbose is set.
 5146: # --------------------------------------------------
 5147: sub _analyze_parameter_type {
●5148 → 5152 → 5171 5148: 	my ($self, $p_ref, $param, $code) = @_;
 5149: 	my $p = $$p_ref;
 5150: 
 5151: 	# Type inference from ref() checks
 5152: 	if ($code =~ /ref\s*\(\s*\$$param\s*\)\s*eq\s*['"](ARRAY|HASH|SCALAR)['"]/gi) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5153: 		my $reftype = lc($1);
 5154: 		$p->{type} = $reftype eq 'array' ? 'arrayref' :
 5155: 					 $reftype eq 'hash' ? 'hashref' :
 5156: 					 'scalar';
 5157: 		$self->_log("  CODE: $param is $p->{type} (ref check)");
 5158: 	}
 5159: 	# ISA checks for objects
 5160: 	elsif ($code =~ /\$$param\s*->\s*isa\s*\(\s*['"]([^'"]+)['"]\s*\)/i) {
 5161: 		$p->{type} = 'object';
 5162: 		$p->{isa} = $1;
 5163: 		$self->_log("  CODE: $param is object of class $1");
 5164: 	}
 5165: 	# Blessed references
 5166: 	elsif ($code =~ /bless\s+.*\$$param/) {
 5167: 		$p->{type} = 'object';
 5168: 		$self->_log("  CODE: $param is blessed object");
 5169: 	}
 5170: 	# Array/hash operations
●5171 → 5171 → 5180 5171: 	if (!$p->{type}) {

					

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

 5172: 		if ($code =~ /\@\{\s*\$$param\s*\}/ || $code =~ /push\s*\(\s*\@?\$$param/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5173: 			$p->{type} = 'arrayref';
 5174: 		} elsif ($code =~ /\%\{\s*\$$param\s*\}/ || $code =~ /\$$param\s*->\s*\{/) {
 5175: 			$p->{type} = 'hashref';
 5176: 		}
 5177: 	}
 5178: 
 5179: 	# Infer type from the default value if type is unknown
●5180 → 5180 → 5194 5180: 	if (!$p->{type} && exists $p->{_default}) {

					

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

 5181: 		my $default = $p->{_default};
 5182: 		if (ref($default) eq 'HASH') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5183: 			$p->{type} = 'hashref';
 5184: 			$self->_log("  CODE: $param type inferred as hashref from default");
 5185: 		} elsif (ref($default) eq 'ARRAY') {
 5186: 			$p->{type} = 'arrayref';
 5187: 			$self->_log("  CODE: $param type inferred as arrayref from default");
 5188: 		}
 5189: 	}
 5190: 
 5191: 	# ------------------------------------------------------------
 5192: 	# Heuristic numeric inference (low confidence)
 5193: 	# ------------------------------------------------------------
●5194 → 5194 → 0 5194: 	if (!$p->{type}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5195: 		# An explicit looks_like_number($param) check is a direct
 5196: 		# numeric-type assertion by the author, stronger evidence than
 5197: 		# incidental arithmetic adjacency (e.g. $param is only ever
 5198: 		# used inside a defined-or default before the arithmetic, so
 5199: 		# the arithmetic-operator check below never sees $param itself
 5200: 		# next to an operator).
 5201: 		if ($code =~ /\blooks_like_number\s*\(\s*\$$param\s*\)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5202: 			$p->{type} = 'number';
 5203: 			$p->{_type_confidence} = 'heuristic';
 5204: 			$self->_log("  CODE: $param inferred as number (looks_like_number check)");
 5205: 		}
 5206: 		# Numeric operators: + - * / % **
 5207: 		# Use \/(?!\/) to exclude // (defined-or) from matching as division.
 5208: 		elsif (
 5209: 			$code =~ /\$$param\s*(?:[\+\-\*\%]|\/(?!\/))/ ||
 5210: 			$code =~ /(?:[\+\-\*\%]|\/(?!\/))\s*\$$param/ ||
 5211: 			$code =~ /\bint\s*\(\s*\$$param\s*\)/ ||
 5212: 			$code =~ /\babs\s*\(\s*\$$param\s*\)/
 5213: 		) {
 5214: 			$p->{type} = 'number';
 5215: 			$p->{_type_confidence} = 'heuristic';
 5216: 			$self->_log("  CODE: $param inferred as number (numeric operator)");
 5217: 		}
 5218: 		# Numeric comparison
 5219: 		elsif (
 5220: 			$code =~ /\$$param\s*(?:==|!=|<=|>=|<|>)/ ||
 5221: 			$code =~ /(?:==|!=|<=|>=|<|>)\s*\$$param/
 5222: 		) {
 5223: 			$p->{type} = 'number';
 5224: 			$p->{_type_confidence} = 'heuristic';
 5225: 			$self->_log("  CODE: $param inferred as number (numeric comparison)");
 5226: 		}
 5227: 	}
 5228: }
 5229: 
 5230: # --------------------------------------------------
 5231: # _analyze_advanced_types
 5232: #
 5233: # Purpose:    Apply enhanced type detection to a
 5234: #             single parameter, checking for
 5235: #             DateTime objects, file handles,
 5236: #             coderefs, and enum-like constraints
 5237: #             beyond what basic type inference
 5238: #             can determine.
 5239: #
 5240: # Entry:      $p_ref - reference to the parameter
 5241: #                      hashref (modified in place
 5242: #                      via the referenced hash).
 5243: #             $param - the parameter name string.
 5244: #             $code  - method body source string.
 5245: #
 5246: # Exit:       Returns nothing. Modifies the
 5247: #             referenced parameter hashref in place.
 5248: #
 5249: # Side effects: Logs detections to stdout when
 5250: #               verbose is set.
 5251: #
 5252: # Notes:      Delegates to four specialised
 5253: #             detectors: _detect_datetime_type,
 5254: #             _detect_filehandle_type,
 5255: #             _detect_coderef_type, and
 5256: #             _detect_enum_type. Each detector
 5257: #             returns early on first match so
 5258: #             detectors are implicitly prioritised
 5259: #             in that order.
 5260: # --------------------------------------------------
 5261: sub _analyze_advanced_types {
 5262: 	my ($self, $p_ref, $param, $code) = @_;
 5263: 
 5264: 	# Dereference once to get the hash reference
 5265: 	my $p = $$p_ref;
 5266: 
 5267: 	# Now pass the dereferenced hash to the detection methods
 5268: 	$self->_detect_datetime_type($p, $param, $code);
 5269: 	$self->_detect_filehandle_type($p, $param, $code);
 5270: 	$self->_detect_coderef_type($p, $param, $code);
 5271: 	$self->_detect_enum_type($p, $param, $code);
 5272: }
 5273: 
 5274: # --------------------------------------------------
 5275: # _detect_datetime_type
 5276: #
 5277: # Purpose:    Detect DateTime objects, Time::Piece
 5278: #             objects, date strings, ISO 8601
 5279: #             strings, and UNIX timestamps by
 5280: #             analysing code patterns involving
 5281: #             the parameter.
 5282: #
 5283: # Entry:      $p     - parameter hashref (modified
 5284: #                      in place).
 5285: #             $param - parameter name string.
 5286: #             $code  - method body source string.
 5287: #
 5288: # Exit:       Returns nothing. Modifies $p in place,
 5289: #             setting type, isa, semantic, min,
 5290: #             matches, and/or format keys.
 5291: #             Returns immediately on first match.
 5292: #
 5293: # Side effects: Logs detections to stdout when
 5294: #               verbose is set.
 5295: # --------------------------------------------------
 5296: sub _detect_datetime_type {
●5297 → 5303 → 5312 5297: 	my ($self, $p, $param, $code) = @_;
 5298: 
 5299: 	# Validate param is just a simple word
 5300: 	return unless defined $param && $param =~ /^\w+$/;
 5301: 
 5302: 	# DateTime object detection via isa/UNIVERSAL checks
 5303: 	if ($code =~ /\$$param\s*->\s*isa\s*\(\s*['"]DateTime['"]\s*\)/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5304: 		$p->{type} = 'object';
 5305: 		$p->{isa} = 'DateTime';
 5306: 		$p->{semantic} = 'datetime_object';
 5307: 		$self->_log("  ADVANCED: $param is DateTime object");
 5308: 		return;
 5309: 	}
 5310: 
 5311: 	# Check for DateTime method calls
●5312 → 5312 → 5321 5312: 	if ($code =~ /\$$param\s*->\s*(ymd|dmy|mdy|hms|iso8601|epoch|strftime)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5313: 		$p->{type} = 'object';
 5314: 		$p->{isa} = 'DateTime';
 5315: 		$p->{semantic} = 'datetime_object';
 5316: 		$self->_log("  ADVANCED: $param uses DateTime methods");
 5317: 		return;
 5318: 	}
 5319: 
 5320: 	# Time::Piece detection
●5321 → 5321 → 5331 5321: 	if ($code =~ /\$$param\s*->\s*isa\s*\(\s*['"]Time::Piece['"]\s*\)/i ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5322: 	    $code =~ /\$$param\s*->\s*(strftime|epoch|year|mon|mday)/) {
 5323: 		$p->{type} = 'object';
 5324: 		$p->{isa} = 'Time::Piece';
 5325: 		$p->{semantic} = 'timepiece_object';
 5326: 		$self->_log("  ADVANCED: $param is Time::Piece object");
 5327: 		return;
 5328: 	}
 5329: 
 5330: 	# String date/time patterns via regex matching
●5331 → 5331 → 5340 5331: 	if ($code =~ /\$$param\s*=~\s*\/.*?\\d\{4\}.*?\\d\{2\}.*?\\d\{2\}/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5332: 		$p->{type} = 'string';
 5333: 		$p->{semantic} = 'date_string';
 5334: 		$p->{format} = 'YYYY-MM-DD or similar';
 5335: 		$self->_log("  ADVANCED: $param validated as date string pattern");
 5336: 		return;
 5337: 	}
 5338: 
 5339: 	# ISO 8601 date pattern
●5340 → 5340 → 5349 5340: 	if ($code =~ /\$$param\s*=~\s*\/.*?[Tt].*?[Zz].*?\//) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5341: 		$p->{type} = 'string';
 5342: 		$p->{semantic} = 'iso8601_string';
 5343: 		$p->{matches} = '/^\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}Z?$/';
 5344: 		$self->_log("  ADVANCED: $param validated as ISO 8601 datetime");
 5345: 		return;
 5346: 	}
 5347: 
 5348: 	# UNIX timestamp detection (numeric with specific range)
●5349 → 5349 → 5360 5349: 	if ($code =~ /\$$param\s*>\s*\d{9,}/ || # UNIX timestamps are 10+ digits

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5350: 	    $code =~ /time\(\s*\)\s*-\s*\$$param/ ||
 5351: 	    $code =~ /\$$param\s*-\s*time\(\s*\)/) {
 5352: 		$p->{type} = 'integer';
 5353: 		$p->{semantic} = 'unix_timestamp';
 5354: 		$p->{min} = 0;
 5355: 		$self->_log("  ADVANCED: $param appears to be UNIX timestamp");
 5356: 		return;
 5357: 	}
 5358: 
 5359: 	# Date parsing with strptime or similar
●5360 → 5360 → 0 5360: 	if ($code =~ /strptime\s*\(\s*\$$param/ ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5361: 	    $code =~ /DateTime::Format::\w+\s*->\s*parse_datetime\s*\(\s*\$$param/) {
 5362: 		$p->{type} = 'string';
 5363: 		$p->{semantic} = 'datetime_parseable';
 5364: 		$self->_log("  ADVANCED: $param is parsed as datetime");
 5365: 		return;
 5366: 	}
 5367: }
 5368: 
 5369: # --------------------------------------------------
 5370: # _detect_filehandle_type
 5371: #
 5372: # Purpose:    Detect file handle parameters and
 5373: #             file path string parameters by
 5374: #             analysing I/O operations, file test
 5375: #             operators, and path manipulation
 5376: #             patterns involving the parameter.
 5377: #
 5378: # Entry:      $p     - parameter hashref (modified
 5379: #                      in place).
 5380: #             $param - parameter name string.
 5381: #             $code  - method body source string.
 5382: #
 5383: # Exit:       Returns nothing. Modifies $p in place,
 5384: #             setting type, isa, and semantic keys.
 5385: #             Returns immediately on first match.
 5386: #
 5387: # Side effects: Logs detections to stdout when
 5388: #               verbose is set.
 5389: # --------------------------------------------------
 5390: sub _detect_filehandle_type {
●5391 → 5396 → 5405 5391: 	my ($self, $p, $param, $code) = @_;
 5392: 
 5393: 	return unless defined $param && $param =~ /^\w+$/;
 5394: 
 5395: 	# File handle operations
 5396: 	if ($code =~ /(?:open|close|read|print|say|sysread|syswrite)\s*\(?\s*\$$param/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5397: 		$p->{type} = 'object';
 5398: 		$p->{isa} = 'IO::Handle';
 5399: 		$p->{semantic} = 'filehandle';
 5400: 		$self->_log("  ADVANCED: $param is a file handle");
 5401: 		return;
 5402: 	}
 5403: 
 5404: 	# Filehandle-specific operations
●5405 → 5405 → 5414 5405: 	if ($code =~ /\$$param\s*->\s*(readline|getline|print|say|close|flush|autoflush)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5406: 		$p->{type} = 'object';
 5407: 		$p->{isa} = 'IO::Handle';
 5408: 		$p->{semantic} = 'filehandle';
 5409: 		$self->_log("  ADVANCED: $param uses filehandle methods");
 5410: 		return;
 5411: 	}
 5412: 
 5413: 	# File test operators
●5414 → 5414 → 5422 5414: 	if ($code =~ /(?:-[frwxoOeszlpSbctugkTBMAC])\s+\$$param/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5415: 		$p->{type} = 'string';
 5416: 		$p->{semantic} = 'filepath';
 5417: 		$self->_log("  ADVANCED: $param is tested as file path");
 5418: 		return;
 5419: 	}
 5420: 
 5421: 	# File::Spec operations or path manipulation
●5422 → 5422 → 5432 5422: 	if ($code =~ /File::(?:Spec|Basename)::\w+\s*\(\s*\$$param/ ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5423: 	    $code =~ /(?:basename|dirname|fileparse)\s*\(\s*\$$param/) {
 5424: 		$p->{type} = 'string';
 5425: 		$p->{semantic} = 'filepath';
 5426: 		$self->_log("  ADVANCED: $param manipulated as file path");
 5427: 		return;
 5428: 	}
 5429: 
 5430: 	# Path validation patterns
 5431: 	# Only match a literal path assigned or defaulted to this variable
●5432 → 5432 → 5440 5432: 	if(defined $p->{_default} && $p->{_default} =~ m{^([A-Za-z]:\\|/|\./|\.\./)}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5433: 		$p->{type} = 'string';
 5434: 		$p->{semantic} = 'filepath';
 5435: 		$self->_log("  ADVANCED: $param default looks like a path");
 5436: 		return;
 5437: 	}
 5438: 
 5439: 	# IO::File detection
●5440 → 5440 → 0 5440: 	if ($code =~ /\$$param\s*->\s*isa\s*\(\s*['"]IO::File['"]\s*\)/ ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5441: 	    $code =~ /IO::File\s*->\s*new\s*\(\s*\$$param/) {
 5442: 		$p->{type} = 'object';
 5443: 		$p->{isa} = 'IO::File';
 5444: 		$p->{semantic} = 'filehandle';
 5445: 		$self->_log("  ADVANCED: $param is IO::File object");
 5446: 		return;
 5447: 	}
 5448: }
 5449: 
 5450: # --------------------------------------------------
 5451: # _detect_coderef_type
 5452: #
 5453: # Purpose:    Detect coderef and callback parameters
 5454: #             by analysing ref() checks, invocation
 5455: #             patterns, and parameter naming
 5456: #             conventions.
 5457: #
 5458: # Entry:      $p     - parameter hashref (modified
 5459: #                      in place).
 5460: #             $param - parameter name string.
 5461: #             $code  - method body source string.
 5462: #
 5463: # Exit:       Returns nothing. Modifies $p in place,
 5464: #             setting type and semantic keys.
 5465: #             Returns immediately on first match.
 5466: #
 5467: # Side effects: Logs detections to stdout when
 5468: #               verbose is set.
 5469: # --------------------------------------------------
 5470: sub _detect_coderef_type {
●5471 → 5476 → 5484 5471: 	my ($self, $p, $param, $code) = @_;
 5472: 
 5473: 	return unless defined $param && $param =~ /^\w+$/;
 5474: 
 5475: 	# ref() check for CODE
 5476: 	if ($code =~ /ref\s*\(\s*\$$param\s*\)\s*eq\s*['"]CODE['"]/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5477: 		$p->{type} = 'coderef';
 5478: 		$p->{semantic} = 'callback';
 5479: 		$self->_log("  ADVANCED: $param is coderef (ref check)");
 5480: 		return;
 5481: 	}
 5482: 
 5483: 	# Invocation as coderef - note the escaped @ in \@_
●5484 → 5484 → 5494 5484: 	if ($code =~ /\$$param\s*->\s*\(/ ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5485: 	    $code =~ /\$$param\s*->\s*\(\s*\@_\s*\)/ ||
 5486: 	    $code =~ /&\s*\{\s*\$$param\s*\}/) {
 5487: 		$p->{type} = 'coderef';
 5488: 		$p->{semantic} = 'callback';
 5489: 		$self->_log("  ADVANCED: $param invoked as coderef");
 5490: 		return;
 5491: 	}
 5492: 
 5493: 	# Parameter name suggests callback
●5494 → 5494 → 5502 5494: 	if ($param =~ /^(?:callback|cb|handler|sub|code|fn|func|on_\w+)$/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5495: 		$p->{type} = 'coderef';
 5496: 		$p->{semantic} = 'callback';
 5497: 		$self->_log("  ADVANCED: $param name suggests coderef");
 5498: 		return;
 5499: 	}
 5500: 
 5501: 	# Blessed coderef (unusual but valid)
●5502 → 5502 → 0 5502: 	if ($code =~ /blessed\s*\(\s*\$$param\s*\)/ &&

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5503: 	    $code =~ /ref\s*\(\s*\$$param\s*\)\s*eq\s*['"]CODE['"]/i) {
 5504: 		$p->{type} = 'object';
 5505: 		$p->{isa} = 'blessed_coderef';
 5506: 		$p->{semantic} = 'callback';
 5507: 		$self->_log("  ADVANCED: $param is blessed coderef");
 5508: 		return;
 5509: 	}
 5510: }
 5511: 
 5512: # --------------------------------------------------
 5513: # _detect_enum_type
 5514: #
 5515: # Purpose:    Detect enum-like parameters whose
 5516: #             valid values are a fixed set, by
 5517: #             analysing validation patterns
 5518: #             including regex alternations, hash
 5519: #             lookups, grep checks, given/when,
 5520: #             if/elsif chains, and smart match.
 5521: #
 5522: # Entry:      $p     - parameter hashref (modified
 5523: #                      in place).
 5524: #             $param - parameter name string.
 5525: #             $code  - method body source string.
 5526: #
 5527: # Exit:       Returns nothing. Modifies $p in place,
 5528: #             setting type, enum, and semantic keys.
 5529: #             Returns immediately on first match.
 5530: #
 5531: # Side effects: Logs detections to stdout when
 5532: #               verbose is set.
 5533: #
 5534: # Notes:      Requires at least 3 if/elsif branches
 5535: #             for pattern 5 to avoid false positives
 5536: #             from ordinary conditional code.
 5537: # --------------------------------------------------
 5538: sub _detect_enum_type {
●5539 → 5545 → 5558 5539: 	my ($self, $p, $param, $code) = @_;
 5540: 
 5541: 	return unless defined $param && $param =~ /^\w+$/;
 5542: 
 5543: 	# Pattern 1: die/croak unless value is in list
 5544: 	# die 'Invalid status' unless $status =~ /^(active|inactive|pending)$/;
 5545: 	if ($code =~ /unless\s+\$$param\s*=~\s*\/\^?\(([^)]+)\)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5546: 		my $values = $1;
 5547: 		my @enum_values = split(/\|/, $values);
 5548: 		$p->{type} = 'string' unless $p->{type};
 5549: 		$p->{enum} = \@enum_values;
 5550: 		$p->{semantic} = 'enum';
 5551: 		$self->_log("  ADVANCED: $param is enum with values: " . join(', ', @enum_values));
 5552: 		return;
 5553: 	}
 5554: 
 5555: 	# Pattern 2: Hash lookup for validation
 5556: 	# my %valid = map { $_ => 1 } qw(red green blue);
 5557: 	# die unless $valid{$param};
●5558 → 5558 → 5573 5558: 	if ($code =~ /\%(\w+)\s*=.*?qw\s*[\(\[<{]([^)\]>}]+)[\)\]>}]/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5559: 		my $hash_name = $1;
 5560: 		my $values_str = $2;
 5561: 		if (defined $values_str && $code =~ /\$$hash_name\s*\{\s*\$$param\s*\}/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5562: 			my @enum_values = split(/\s+/, $values_str);
 5563: 			$p->{type} = 'string' unless $p->{type};
 5564: 			$p->{enum} = \@enum_values;
 5565: 			$p->{semantic} = 'enum';
 5566: 			$self->_log("  ADVANCED: $param validated via hash lookup: " . join(', ', @enum_values));
 5567: 			return;
 5568: 		}
 5569: 	}
 5570: 
 5571: 	# Pattern 3: Array grep validation
 5572: 	# die unless grep { $_ eq $param } qw(foo bar baz);
●5573 → 5573 → 5584 5573: 	if ($code =~ /grep\s*\{[^}]*\$$param[^}]*\}\s*qw\s*[\(\[<{]([^)\]>}]+)[\)\]>}]/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5574: 		my $values_str = $1;
 5575: 		my @enum_values = split(/\s+/, $values_str);
 5576: 		$p->{type} = 'string' unless $p->{type};
 5577: 		$p->{enum} = \@enum_values;
 5578: 		$p->{semantic} = 'enum';
 5579: 		$self->_log("  ADVANCED: $param validated via grep: " . join(', ', @enum_values));
 5580: 		return;
 5581: 	}
 5582: 
 5583: 	# Pattern 4: Given/when (Perl 5.10+)
●5584 → 5584 → 5600 5584: 	if ($code =~ /given\s*\(\s*\$$param\s*\)/) {

					

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

 5585: 		my @enum_values;
 5586: 		while ($code =~ /when\s*\(\s*['"]([^'"]+)['"]\s*\)/g) {
 5587: 			push @enum_values, $1;
 5588: 		}
 5589: 		if (@enum_values >= 2) {

					

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

 5590: 			$p->{type} = 'string' unless $p->{type};
 5591: 			$p->{enum} = \@enum_values;
 5592: 			$p->{semantic} = 'enum';
 5593: 			$self->_log("  ADVANCED: $param has enum values from given/when: " .
 5594: 			           join(', ', @enum_values));
 5595: 			return;
 5596: 		}
 5597: 	}
 5598: 
 5599: 	# Pattern 5: Multiple if/elsif checking specific values
●5600 → 5601 → 5604 5600: 	my @if_values;
 5601: 	while ($code =~ /if\s*\(\s*\$$param\s*eq\s*['"]([^'"]+)['"]\s*\)/g) {
 5602: 		push @if_values, $1;
 5603: 	}
●5604 → 5604 → 5607 5604: 	while ($code =~ /elsif\s*\(\s*\$$param\s*eq\s*['"]([^'"]+)['"]\s*\)/g) {
 5605: 		push @if_values, $1;
 5606: 	}
●5607 → 5607 → 5617 5607: 	if (@if_values >= 3) {

					

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

 5608: 		$p->{type} = 'string' unless $p->{type};
 5609: 		$p->{enum} = \@if_values;
 5610: 		$p->{semantic} = 'enum';
 5611: 		$self->_log("  ADVANCED: $param appears to be enum from if/elsif: " .
 5612: 		           join(', ', @if_values));
 5613: 		return;
 5614: 	}
 5615: 
 5616: 	# Pattern 6: Smart match (~~) with array
●5617 → 5617 → 0 5617: 	if ($code =~ /\$$param\s*~~\s*\[([^\]]+)\]/ ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5618: 	    $code =~ /\$$param\s*~~\s*qw\s*[\(\[<{]([^)\]>}]+)[\)\]>}]/) {
 5619: 		my $values_str = $1;
 5620: 		my @enum_values;
 5621: 		if ($values_str =~ /['"]/) {

					

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

 5622: 			@enum_values = $values_str =~ /['"](.*?)['"]/g;
 5623: 		} else {
 5624: 			@enum_values = split(/\s+/, $values_str);
 5625: 		}
 5626: 		if (@enum_values) {

					

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

 5627: 			$p->{type} = 'string' unless $p->{type};
 5628: 			$p->{enum} = \@enum_values;
 5629: 			$p->{semantic} = 'enum';
 5630: 			$self->_log("  ADVANCED: $param validated with smart match: " .
 5631: 				   join(', ', @enum_values));
 5632: 			return;
 5633: 		}
 5634: 	}
 5635: }
 5636: 
 5637: # --------------------------------------------------
 5638: # _extract_error_constraints
 5639: #
 5640: # Purpose:    Extract invalid-value constraints and
 5641: #             error messages from die/croak patterns
 5642: #             referencing a specific parameter, and
 5643: #             infer numeric bounds from comparisons
 5644: #             with literals.
 5645: #
 5646: # Entry:      $p_ref - reference to the parameter
 5647: #                      hashref (modified in place).
 5648: #             $param - parameter name string.
 5649: #             $code  - method body source string.
 5650: #
 5651: # Exit:       Returns nothing. May add _invalid,
 5652: #             _errors, min, and/or max to the
 5653: #             referenced parameter hashref.
 5654: #
 5655: # Side effects: Logs detections to stdout when
 5656: #               verbose is set.
 5657: # --------------------------------------------------
 5658: sub _extract_error_constraints {
●5659 → 5662 → 5718 5659: 	my ($self, $p, $param, $code) = @_;
 5660: 
 5661: 	# Look for die/croak/confess with a condition involving this param
 5662: 	while ($code =~ /
 5663: 		(?:die|croak|confess)       # error call
 5664: 		\s*
 5665: 		(?:
 5666: 			["']([^"']+)["']        # captured error message
 5667: 		|
 5668: 			q[qw]?\s*[\(\[]([^)\]]+)[\)\]]  # q(), qq(), qw()
 5669: 		)?
 5670: 		\s*
 5671: 		if\s+
 5672: 		(.+?)                      # condition
 5673: 		\s*;
 5674: 	/gsx) {
 5675: 
 5676: 		my $message = $1 || $2;
 5677: 		my $condition = $3;
 5678: 
 5679: 		# Only keep conditions that reference this parameter
 5680: 		next unless $condition =~ /\$$param\b/;
 5681: 
 5682: 		# Initialize storage
 5683: 		$$p->{_invalid} ||= [];
 5684: 		$$p->{_errors}  ||= [];
 5685: 
 5686: 		# Normalize condition (strip surrounding parens)
 5687: 		$condition =~ s/^\(|\)$//g;
 5688: 		$condition =~ s/\s+/ /g;
 5689: 
 5690: 		# Try to extract a meaningful invalid constraint
 5691: 		my $constraint;
 5692: 
 5693: 		# Examples:
 5694: 		#   $age <= 0
 5695: 		#   $x eq ''
 5696: 		#   length($s) < 3
 5697: 		if ($condition =~ /\$$param\s*([!<>=]=?|eq|ne|lt|gt|le|ge)\s*(.+)/) {

					

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

 5698: 			$constraint = "$1 $2";
 5699: 		}
 5700: 		elsif ($condition =~ /length\s*\(\s*\$$param\s*\)\s*([<>=!]+)\s*(\d+)/) {
 5701: 			$constraint = "length $1 $2";
 5702: 		}
 5703: 		elsif ($condition =~ /\$$param\s*==\s*0/) {
 5704: 			$constraint = '== 0';
 5705: 		}
 5706: 
 5707: 		# Store results
 5708: 		push @{ $$p->{_invalid} }, $constraint if $constraint;
 5709: 		push @{ $$p->{_errors}  }, $message if defined $message;
 5710: 
 5711: 		$self->_log(
 5712: 			"  ERROR: $param invalid when [$condition]" .
 5713: 			(defined $message ? " => '$message'" : '')
 5714: 		);
 5715: 	}
 5716: 
 5717: 	# Numeric comparison with literal
●5718 → 5718 → 0 5718: 	if ($code =~ /\b\Q$param\E\s*(<=|<|>=|>)\s*(-?\d+)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5719: 		my ($op, $num) = ($1, $2);
 5720: 
 5721: 		# Mark required
 5722: 		$$p->{optional} = 0;
 5723: 
 5724: 		if ($op eq '<=') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5725: 			$$p->{min} = $num + 1;
 5726: 		} elsif ($op eq '<') {
 5727: 			$$p->{min} = $num;
 5728: 		} elsif ($op eq '>=') {
 5729: 			$$p->{max} = $num - 1;
 5730: 		} elsif ($op eq '>') {
 5731: 			$$p->{max} = $num;
 5732: 		}
 5733: 
 5734: 		$self->_log("  ERROR: $param normalized constraint from '$op $num'");
 5735: 	}
 5736: }
 5737: 
 5738: # --------------------------------------------------
 5739: # _extract_parameters_from_signature
 5740: #
 5741: # Purpose:    Extract parameter names and positions
 5742: #             from a method's signature, trying
 5743: #             modern Perl subroutine signatures
 5744: #             first and falling back to traditional
 5745: #             @_ extraction styles.
 5746: #
 5747: # Entry:      $params - hashref to populate with
 5748: #                       parameter specs (modified
 5749: #                       in place).
 5750: #             $code   - method body source string.
 5751: #
 5752: # Exit:       Returns nothing. Populates $params.
 5753: #
 5754: # Side effects: Logs detections to stdout when
 5755: #               verbose is set.
 5756: #
 5757: # Notes:      Three traditional styles are
 5758: #             supported: (1) my ($self, ...) = @_,
 5759: #             (2) my $self = shift; my $x = shift,
 5760: #             (3) my $x = $_[N]. $self and $class
 5761: #             are always excluded from the returned
 5762: #             parameters.
 5763: # --------------------------------------------------
 5764: sub _extract_parameters_from_signature {
●5765 → 5778 → 5792 5765: 	my ($self, $params, $code) = @_;
 5766: 
 5767: 	# Modern Style: Subroutine signatures with attributes
 5768: 	# Handle multi-line signatures
 5769: 	# sub foo :attr1 :attr2(val) (
 5770: 	#     $self,
 5771: 	#     $x :Type,
 5772: 	#     $y = default
 5773: 	# ) { }
 5774: 
 5775: 	# Try to match signature after attributes
 5776: 	# Look for the parameter list - it's the last (...) before the opening brace
 5777: 	# that contains sigils ($, %, @)
 5778: 	if ($code =~ /sub\s+\w+\s*(?::\w+(?:\([^)]*\))?\s*)*\(((?:[^()]|\([^)]*\))*)\)\s*\{/s) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5779: 		my $potential_sig = $1;
 5780: 
 5781: 		# Check if this looks like parameters (has sigils)
 5782: 		if ($potential_sig =~ /[\$\%\@]/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5783: 			$self->_log("  SIG: Found modern signature: ($potential_sig)");
 5784: 			$self->_parse_modern_signature($params, $potential_sig);
 5785: 			return;
 5786: 		}
 5787: 	}
 5788: 
 5789: 	# Direct-index style: my $self = $_[0];  my $arg = $_[1]; ...
 5790: 	# Must be checked before Style 1 to avoid matching @_ inside closures
 5791: 	# defined in the body of a method that uses this style.
●5792 → 5792 → 5804 5792: 	if($code =~ /my\s+\$(?:self|class)\s*=\s*\$_\[0\]/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5793: 		my $pos = 0;
 5794: 		while($code =~ /my\s+\$(\w+)\s*=\s*\$_\[(\d+)\]/g) {
 5795: 			my $name = $1;
 5796: 			next if $name =~ /^(self|class)$/i;
 5797: 			$params->{$name} //= { _source => 'code', optional => 1, position => $pos++ };
 5798: 			$self->_log("  CODE: Found direct-index parameter '\$$name' at \$_[$2]");
 5799: 		}
 5800: 		return;
 5801: 	}
 5802: 
 5803: 	# Traditional Style 1: my ($self, $arg1, $arg2) = @_;
●5804 → 5804 → 5838 5804: 	if ($code =~ /my\s*\(\s*([^)]+)\)\s*=\s*\@_/s) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5805: 		my $sig = $1;
 5806: 		my $pos = 0;
 5807: 
 5808: 		while ($sig =~ /\$(\w+)/g) {
 5809: 			my $name = $1;
 5810: 
 5811: 			next if $name =~ /^(self|class)$/i;
 5812: 
 5813: 			$params->{$name} //= {
 5814: 				_source => 'code',
 5815: 				optional => 1,
 5816: 			};
 5817: 
 5818: 			$params->{$name}{position} = $pos unless exists $params->{$name}{position};
 5819: 
 5820: 			$pos++;
 5821: 		}
 5822: 		return;
 5823: 	} elsif ($code =~ /my\s+\$self\s*=\s*shift/) {
 5824: 		# Traditional Style 2: my $self = shift; my $arg1 = shift;
 5825: 		my @shifts;
 5826: 		while ($code =~ /my\s+\$(\w+)\s*=\s*shift/g) {
 5827: 			push @shifts, $1;
 5828: 		}
 5829: 		shift @shifts if @shifts && $shifts[0] =~ /^(self|class)$/i;
 5830: 		my $pos = 0;
 5831: 		foreach my $param (@shifts) {
 5832: 			$params->{$param} ||= { _source => 'code', optional => 1, position => $pos++ };
 5833: 		}
 5834: 		return;
 5835: 	}
 5836: 
 5837: 	# Traditional Style 3: Function parameters (no $self)
●5838 → 5838 → 5849 5838: 	if ($code =~ /my\s*\(\s*([^)]+)\)\s*=\s*\@_/s) {

					

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

 5839: 		my $sig = $1;
 5840: 		my @param_names = $sig =~ /\$(\w+)/g;
 5841: 		my $pos = 0;
 5842: 		foreach my $param (@param_names) {
 5843: 			next if $param =~ /^(self|class)$/i;
 5844: 			$params->{$param} ||= { _source => 'code', optional => 1, position => $pos++ };
 5845: 		}
 5846: 	}
 5847: 
 5848: 	# De-duplicate
●5849 → 5850 → 0 5849: 	my %seen;
 5850: 	foreach my $param (keys %$params) {
 5851: 		if ($seen{$param}++) {

					

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

 5852: 			$self->_log("  WARNING: Duplicate parameter '$param' found");
 5853: 		}
 5854: 	}
 5855: }
 5856: 
 5857: # --------------------------------------------------
 5858: # _parse_modern_signature
 5859: #
 5860: # Purpose:    Parse a Perl 5.20+ subroutine
 5861: #             signature string into individual
 5862: #             parameter specs, respecting nested
 5863: #             structures when splitting on commas.
 5864: #
 5865: # Entry:      $params - hashref to populate
 5866: #                       (modified in place).
 5867: #             $sig    - signature string with outer
 5868: #                       parentheses already removed.
 5869: #
 5870: # Exit:       Returns nothing. Populates $params
 5871: #             via _parse_signature_parameter.
 5872: #
 5873: # Side effects: Logs parsing details to stdout when
 5874: #               verbose is set.
 5875: # --------------------------------------------------
 5876: sub _parse_modern_signature {
●5877 → 5888 → 5906 5877: 	my ($self, $params, $sig) = @_;
 5878: 
 5879: 	$self->_log("  DEBUG: Parsing signature: [$sig]");
 5880: 
 5881: 	# Split signature by commas, but respect nested structures (e.g. a
 5882: 	# default value containing a hashref/arrayref literal)
 5883: 	require Text::Balanced;
 5884: 	my @parts;
 5885: 	my $current = '';
 5886: 	my $rest = $sig;
 5887: 
 5888: 	while (length $rest) {
 5889: 		if (substr($rest, 0, 1) =~ /[(\[{]/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5890: 			# extract_bracketed advances $rest past the extracted block
 5891: 			# in place, so $rest must not be re-truncated afterwards
 5892: 			my $extracted = Text::Balanced::extract_bracketed($rest, '(){}[]');
 5893: 			last unless defined $extracted;	# Unbalanced brackets
 5894: 			$current .= $extracted;
 5895: 			next;
 5896: 		}
 5897: 		if (substr($rest, 0, 1) eq ',') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5898: 			push @parts, $current;
 5899: 			$current = '';
 5900: 			$rest = substr($rest, 1);
 5901: 			next;
 5902: 		}
 5903: 		$current .= substr($rest, 0, 1);
 5904: 		$rest = substr($rest, 1);
 5905: 	}
●5906 → 5910 → 0 5906: 	push @parts, $current if $current =~ /\S/;
 5907: 
 5908: 	my $position = 0;
 5909: 
 5910: 	foreach my $part (@parts) {
 5911: 		$part =~ s/^\s+|\s+$//g;
 5912: 
 5913: 		# Skip empty parts
 5914: 		next unless $part;
 5915: 
 5916: 		# Parse different parameter types
 5917: 		my $param_info = $self->_parse_signature_parameter($part, $position);
 5918: 
 5919: 		if ($param_info) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5920: 			my $name = $param_info->{name};
 5921: 
 5922: 			# Skip self/class
 5923: 			if ($name =~ /^(self|class)$/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5924: 				next;
 5925: 			}
 5926: 
 5927: 			$params->{$name} = $param_info;
 5928: 			$self->_log("  SIG: $name has position $position" .
 5929: 				($param_info->{optional} ? ' (optional)' : '') .
 5930: 				($param_info->{_default} ? ", default: $param_info->{_default}" : ''));
 5931: 			$position++;
 5932: 		}
 5933: 	}
 5934: }
 5935: 
 5936: # --------------------------------------------------
 5937: # _parse_signature_parameter
 5938: #
 5939: # Purpose:    Parse a single parameter declaration
 5940: #             from a modern Perl signature, handling
 5941: #             type constraints, default values,
 5942: #             plain scalars, and slurpy array/hash
 5943: #             parameters.
 5944: #
 5945: # Entry:      $part     - a single parameter string
 5946: #                         (one comma-separated
 5947: #                         element from the signature).
 5948: #             $position - zero-based position index
 5949: #                         of this parameter.
 5950: #
 5951: # Exit:       Returns a parameter info hashref on
 5952: #             success, or undef if the string does
 5953: #             not match any known pattern.
 5954: #
 5955: # Side effects: None.
 5956: #
 5957: # Notes:      Six patterns are tried in order:
 5958: #             (1) :Type with default,
 5959: #             (2) :Type without default,
 5960: #             (3) default without type,
 5961: #             (4) plain $name,
 5962: #             (5) slurpy @name,
 5963: #             (6) slurpy %name.
 5964: # --------------------------------------------------
 5965: sub _parse_signature_parameter {
●5966 → 5975 → 6065 5966: 	my ($self, $part, $position) = @_;
 5967: 
 5968: 	my %info = (
 5969: 		_source => 'signature',
 5970: 		position => $position,
 5971: 		optional => 0,
 5972: 	);
 5973: 
 5974: 	# Pattern 1: Type constraint WITH default: $name :Type = default
 5975: 	if ($part =~ /^\$(\w+)\s*:\s*(\w+)\s*=\s*(.+)$/s) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5976: 		my ($name, $constraint, $default) = ($1, $2, $3);
 5977: 		$default =~ s/^\s+|\s+$//g;
 5978: 
 5979: 		$info{name} = $name;
 5980: 		$info{optional} = 1;
 5981: 		$info{_default} = $self->_clean_default_value($default, 1);
 5982: 
 5983: 		# Apply type constraint
 5984: 		if ($constraint =~ /^(Int|Integer)$/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 5985: 			$info{type} = 'integer';
 5986: 		} elsif ($constraint =~ /^(Num|Number)$/i) {
 5987: 			$info{type} = 'number';
 5988: 		} elsif ($constraint =~ /^(Str|String)$/i) {
 5989: 			$info{type} = 'string';
 5990: 		} elsif ($constraint =~ /^(Bool|Boolean)$/i) {
 5991: 			$info{type} = 'boolean';
 5992: 		} elsif ($constraint =~ /^(Array|ArrayRef)$/i) {
 5993: 			$info{type} = 'arrayref';
 5994: 		} elsif ($constraint =~ /^(Hash|HashRef)$/i) {
 5995: 			$info{type} = 'hashref';
 5996: 		} else {
 5997: 			$info{type} = 'object';
 5998: 			$info{isa} = $constraint;
 5999: 		}
 6000: 
 6001: 		return \%info;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 6002: 	} elsif ($part =~ /^\$(\w+)\s*:\s*(\w+)\s*$/s) {
 6003: 		# Pattern 2: Type constraint WITHOUT default: $name :Type
 6004: 		my ($name, $constraint) = ($1, $2);
 6005: 		$info{name} = $name;
 6006: 		$info{optional} = 0;
 6007: 
 6008: 		# Apply type constraint (same as above)
 6009: 		if ($constraint =~ /^(Int|Integer)$/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6010: 			$info{type} = 'integer';
 6011: 		} elsif ($constraint =~ /^(Num|Number)$/i) {
 6012: 			$info{type} = 'number';
 6013: 		} elsif ($constraint =~ /^(Str|String)$/i) {
 6014: 			$info{type} = 'string';
 6015: 		} elsif ($constraint =~ /^(Bool|Boolean)$/i) {
 6016: 			$info{type} = 'boolean';
 6017: 		} elsif ($constraint =~ /^(Array|ArrayRef)$/i) {
 6018: 			$info{type} = 'arrayref';
 6019: 		} elsif ($constraint =~ /^(Hash|HashRef)$/i) {
 6020: 			$info{type} = 'hashref';
 6021: 		} else {
 6022: 			$info{type} = 'object';
 6023: 			$info{isa} = $constraint;
 6024: 		}
 6025: 
 6026: 		return \%info;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 6027: 	} elsif ($part =~ /^\$(\w+)\s*=\s*(.+)$/s) {
 6028: 		# Pattern 3: Default WITHOUT type: $name = default
 6029: 		my ($name, $default) = ($1, $2);
 6030: 		$default =~ s/^\s+|\s+$//g;
 6031: 
 6032: 	$info{name} = $name;
 6033: 	$info{optional} = 1;
 6034: 	$info{_default} = $self->_clean_default_value($default, 1);
 6035: 	$info{type} = $self->_infer_type_from_default($info{_default}) if $self->can('_infer_type_from_default');
 6036: 
 6037: 	return \%info;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 6038: 	}
 6039: 
 6040:     # Pattern 4: Plain parameter: $name
 6041:     elsif ($part =~ /^\$(\w+)$/s) {
 6042:         $info{name} = $1;
 6043:         $info{optional} = 0;
 6044:         return \%info;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 6045:     }
 6046: 
 6047:     # Pattern 5: Array parameter: @name
 6048:     elsif ($part =~ /^\@(\w+)$/s) {
 6049:         $info{name} = $1;
 6050:         $info{type} = 'array';
 6051:         $info{slurpy} = 1;
 6052:         $info{optional} = 1;
 6053:         return \%info;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 6054:     }
 6055: 
 6056:     # Pattern 6: Hash parameter: %name
 6057:     elsif ($part =~ /^\%(\w+)$/s) {
 6058:         $info{name} = $1;
 6059:         $info{type} = 'hash';
 6060:         $info{slurpy} = 1;
 6061:         $info{optional} = 1;
 6062:         return \%info;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 6063:     }
 6064: 
 6065: 	return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 6066: }
 6067: 
 6068: # --------------------------------------------------
 6069: # _infer_type_from_default
 6070: #
 6071: # Purpose:    Infer a parameter type from its
 6072: #             default value when no explicit type
 6073: #             annotation is available.
 6074: #
 6075: # Entry:      $default - the cleaned default value
 6076: #                        scalar, hashref, or
 6077: #                        arrayref. May be undef.
 6078: #
 6079: # Exit:       Returns a type string ('hashref',
 6080: #             'arrayref', 'integer', 'number',
 6081: #             'boolean', 'string'), or undef if
 6082: #             $default is undef.
 6083: #
 6084: # Side effects: None.
 6085: # --------------------------------------------------
 6086: sub _infer_type_from_default {
●6087 → 6091 → 0 6087: 	my ($self, $default) = @_;
 6088: 
 6089: 	return undef unless defined $default;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 6090: 
 6091: 	if (ref($default) eq 'HASH') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6092: 		return 'hashref';

  Mutants (Total: 2, Killed: 2, Survived: 0)
 6093: 	} elsif (ref($default) eq 'ARRAY') {
 6094: 		return 'arrayref';

  Mutants (Total: 2, Killed: 2, Survived: 0)
 6095: 	} elsif ($default =~ /^-?\d+$/) {
 6096: 		return 'integer';

  Mutants (Total: 2, Killed: 2, Survived: 0)
 6097: 	} elsif ($default =~ /^-?\d+\.\d+$/) {
 6098: 		return 'number';

  Mutants (Total: 2, Killed: 2, Survived: 0)
 6099: 	} elsif ($default eq '1' || $default eq '0') {
 6100: 		return 'boolean';

					

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

 6101: 	} else {
 6102: 		return 'string';

  Mutants (Total: 2, Killed: 2, Survived: 0)
 6103: 	}
 6104: }
 6105: 
 6106: # --------------------------------------------------
 6107: # _extract_subroutine_attributes
 6108: #
 6109: # Purpose:    Extract Perl subroutine attributes
 6110: #             (e.g. :lvalue, :method, :Returns(Int))
 6111: #             from a method's source string.
 6112: #
 6113: # Entry:      $code - method body source string.
 6114: #
 6115: # Exit:       Returns a hashref of attribute name
 6116: #             to value (1 for flag-only attributes,
 6117: #             the attribute argument string for
 6118: #             attributes with values).
 6119: #             Returns an empty hashref if no
 6120: #             attributes are found.
 6121: #
 6122: # Side effects: Logs detections to stdout when
 6123: #               verbose is set.
 6124: # --------------------------------------------------
 6125: sub _extract_subroutine_attributes {
●6126 → 6138 → 6143 6126: 	my ($self, $code) = @_;
 6127: 
 6128: 	my %attributes;
 6129: 
 6130: 	# Extract all attributes from the sub declaration
 6131: 	# Attributes are :name or :name(value) between sub name and either ( or {
 6132: 	# Pattern: sub name ATTRIBUTES ( params ) { }
 6133: 	# or:      sub name ATTRIBUTES { }
 6134: 
 6135: 	# First, find the attributes section (everything between sub name and ( or { )
 6136: 	my $attr_section = '';
 6137: 
 6138: 	if($code =~ /sub\s+\w+\s+((?::\w+(?:\([^)]*\))?\s*)+)/s) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6139: 		$attr_section = $1;
 6140: 	}
 6141: 
 6142: 	# Parse individual attributes from the section
●6143 → 6143 → 6158 6143: 	if($attr_section) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6144: 		while($attr_section =~ /:(\w+)(?:\(([^)]*)\))?/g) {
 6145: 			my ($name, $value) = ($1, $2);
 6146: 
 6147: 			if (defined $value && $value ne '') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6148: 				$attributes{$name} = $value;
 6149: 				$self->_log("  ATTR: Found attribute :$name($value)");
 6150: 			} else {
 6151: 				$attributes{$name} = 1;
 6152: 				$self->_log("  ATTR: Found attribute :$name");
 6153: 			}
 6154: 		}
 6155: 	}
 6156: 
 6157: 	# Process common attributes
●6158 → 6158 → 6165 6158: 	if ($attributes{Returns}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6159: 		my $return_type = $attributes{Returns};
 6160: 		if ($return_type ne '1') {  # Only log if it's an actual type, not just the flag

					

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

 6161: 			$self->_log("  ATTR: Method declares return type: $return_type");
 6162: 		}
 6163: 	}
 6164: 
●6165 → 6165 → 6169 6165: 	if ($attributes{lvalue}) {

					

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

 6166: 		$self->_log("  ATTR: Method is lvalue (can be assigned to)");
 6167: 	}
 6168: 
●6169 → 6169 → 6173 6169: 	if ($attributes{method}) {

					

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

 6170: 		$self->_log('  ATTR: Method explicitly marked as :method');
 6171: 	}
 6172: 
 6173: 	return \%attributes;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 6174: }
 6175: 
 6176: # --------------------------------------------------
 6177: # _analyze_postfix_dereferencing
 6178: #
 6179: # Purpose:    Detect usage of Perl 5.20+ postfix
 6180: #             dereferencing syntax in a method body
 6181: #             and record which dereference forms
 6182: #             are used.
 6183: #
 6184: # Entry:      $code - method body source string.
 6185: #
 6186: # Exit:       Returns a hashref whose keys are
 6187: #             dereference form names (array_deref,
 6188: #             hash_deref, scalar_deref, code_deref,
 6189: #             array_slice, hash_slice) with value 1
 6190: #             when detected.
 6191: #             Returns an empty hashref if no
 6192: #             postfix dereferencing is found.
 6193: #
 6194: # Side effects: Logs detections to stdout when
 6195: #               verbose is set.
 6196: # --------------------------------------------------
 6197: sub _analyze_postfix_dereferencing {
●6198 → 6203 → 6209 6198: 	my ($self, $code) = @_;
 6199: 
 6200: 	my %derefs;
 6201: 
 6202: 	# Array dereference: $ref->@*
 6203: 	if ($code =~ /\$\w+\s*->\s*\@\*/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6204: 		$derefs{array_deref} = 1;
 6205: 		$self->_log("  MODERN: Uses postfix array dereferencing (->@*)");
 6206: 	}
 6207: 
 6208: 	# Hash dereference: $ref->%*
●6209 → 6209 → 6215 6209: 	if ($code =~ /\$\w+\s*->\s*\%\*/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6210: 		$derefs{hash_deref} = 1;
 6211: 		$self->_log("  MODERN: Uses postfix hash dereferencing (->%*)");
 6212: 	}
 6213: 
 6214: 	# Scalar dereference: $ref->$*
●6215 → 6215 → 6221 6215: 	if ($code =~ /\$\w+\s*->\s*\$\*/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6216: 		$derefs{scalar_deref} = 1;
 6217: 		$self->_log('  MODERN: Uses postfix scalar dereferencing (->$*)');
 6218: 	}
 6219: 
 6220: 	# Code dereference: $ref->&*
●6221 → 6221 → 6227 6221: 	if ($code =~ /\$\w+\s*->\s*\&\*/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6222: 		$derefs{code_deref} = 1;
 6223: 		$self->_log("  MODERN: Uses postfix code dereferencing (->&*)");
 6224: 	}
 6225: 
 6226: 	# Array element: $ref->@[0,2,4]
●6227 → 6227 → 6233 6227: 	if ($code =~ /\$\w+\s*->\s*\@\[/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6228: 		$derefs{array_slice} = 1;
 6229: 		$self->_log("  MODERN: Uses postfix array slice (->@[...])");
 6230: 	}
 6231: 
 6232: 	# Hash element: $ref->%{key1,key2}
●6233 → 6233 → 6238 6233: 	if ($code =~ /\$\w+\s*->\s*\%\{/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6234: 		$derefs{hash_slice} = 1;
 6235: 		$self->_log("  MODERN: Uses postfix hash slice (->%{...})");
 6236: 	}
 6237: 
 6238: 	return \%derefs;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 6239: }
 6240: 
 6241: # --------------------------------------------------
 6242: # _extract_field_declarations
 6243: #
 6244: # Purpose:    Extract Perl 5.38 field declarations
 6245: #             from a class body or method source
 6246: #             string, capturing field names,
 6247: #             :param attributes, default values,
 6248: #             and :isa type constraints.
 6249: #
 6250: # Entry:      $code - source string potentially
 6251: #                     containing 'field $name ...'
 6252: #                     declarations.
 6253: #
 6254: # Exit:       Returns a hashref of field name to
 6255: #             field_info hashref. Returns an empty
 6256: #             hashref if no field declarations
 6257: #             are found.
 6258: #
 6259: # Side effects: Logs detections to stdout when
 6260: #               verbose is set.
 6261: # --------------------------------------------------
 6262: sub _extract_field_declarations {
●6263 → 6271 → 6315 6263: 	my ($self, $code) = @_;
 6264: 
 6265: 	my %fields;
 6266: 
 6267: 	# Pattern: field $name :param;
 6268: 	# Pattern: field $name :param(name);
 6269: 	# Pattern: field $name = default;
 6270: 	# More lenient pattern to catch various formats
 6271: 	while ($code =~ /^\s*field\s+\$(\w+)\s*([^;]*);/gm) {
 6272: 		my ($name, $modifiers) = ($1, $2);
 6273: 
 6274: 		$self->_log("  FIELD: Found field \$$name with modifiers: [$modifiers]");
 6275: 
 6276: 		my %field_info = (
 6277: 			name => $name,
 6278: 			_source => 'field'
 6279: 		);
 6280: 
 6281: 		# Check for :param attribute
 6282: 		if ($modifiers =~ /:param(?:\(([^)]+)\))?/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6283: 			$field_info{is_param} = 1;
 6284: 
 6285: 			if (defined $1) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6286: 				# Explicit parameter name
 6287: 				$field_info{param_name} = $1;
 6288: 			} else {
 6289: 				# Implicit - field name is param name
 6290: 				$field_info{param_name} = $name;
 6291: 			}
 6292: 
 6293: 			$self->_log("  FIELD: $name maps to parameter: $field_info{param_name}");
 6294: 		}
 6295: 
 6296:         # Check for default value - must come before type constraint check
 6297: 	if ($modifiers =~ /=\s*([^:;]+)(?::|;|$)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6298: 		my $default = $1;
 6299: 		$default =~ s/\s+$//;
 6300: 		$field_info{_default} = $self->_clean_default_value($default, 1);
 6301: 		$field_info{optional} = 1;
 6302: 		$self->_log("  FIELD: $name has default: " . (defined $field_info{_default} ? $field_info{_default} : 'undef'));
 6303: 	}
 6304: 
 6305: 	# Check for type constraints
 6306: 	if ($modifiers =~ /:isa\(([^)]+)\)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6307: 	    $field_info{isa} = $1;
 6308: 	    $field_info{type} = 'object';
 6309: 	    $self->_log("  FIELD: $name has type constraint: $1");
 6310: 	}
 6311: 
 6312: 		$fields{$name} = \%field_info;
 6313: 	}
 6314: 
 6315: 	return \%fields;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 6316: }
 6317: 
 6318: # --------------------------------------------------
 6319: # _merge_field_declarations
 6320: #
 6321: # Purpose:    Integrate Perl 5.38 field declarations
 6322: #             that carry the :param attribute into
 6323: #             the code parameter hashref, so they
 6324: #             appear as constructor parameters in
 6325: #             the generated schema.
 6326: #
 6327: # Entry:      $params - hashref of parameters
 6328: #                       extracted from code analysis
 6329: #                       (modified in place).
 6330: #             $fields - hashref of field declarations
 6331: #                       as returned by
 6332: #                       _extract_field_declarations.
 6333: #
 6334: # Exit:       Returns nothing. Modifies $params
 6335: #             in place.
 6336: #
 6337: # Side effects: Logs merges to stdout when verbose
 6338: #               is set.
 6339: #
 6340: # Notes:      Only fields with is_param => 1 are
 6341: #             merged. The param_name key in the
 6342: #             field (which may differ from the
 6343: #             field name if :param(name) was used)
 6344: #             determines the parameter key.
 6345: # --------------------------------------------------
 6346: sub _merge_field_declarations {
●6347 → 6349 → 0 6347: 	my ($self, $params, $fields) = @_;
 6348: 
 6349: 	foreach my $field_name (keys %$fields) {
 6350: 		my $field = $fields->{$field_name};
 6351: 
 6352: 		# Only process fields that are parameters
 6353: 		next unless $field->{is_param};
 6354: 
 6355: 		my $param_name = $field->{param_name};
 6356: 
 6357: 		# Create or update parameter info
 6358: 		$params->{$param_name} ||= {};
 6359: 		my $p = $params->{$param_name};
 6360: 
 6361: 		# Merge field information into parameter
 6362: 		$p->{_source} = 'field' unless $p->{_source};
 6363: 		$p->{field_name} = $field_name if $field_name ne $param_name;
 6364: 
 6365: 		if ($field->{_default}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6366: 			$p->{_default} = $field->{_default};
 6367: 			$p->{optional} = 1;
 6368: 		}
 6369: 
 6370: 		if ($field->{isa}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6371: 			$p->{isa} = $field->{isa};
 6372: 			$p->{type} = 'object';
 6373: 		}
 6374: 
 6375: 		$self->_log("  MERGED: Field $field_name -> parameter $param_name");
 6376: 	}
 6377: }
 6378: 
 6379: # --------------------------------------------------
 6380: # _extract_defaults_from_code
 6381: #
 6382: # Purpose:    Scan a method body for default value
 6383: #             assignment patterns and populate the
 6384: #             optional and _default fields of
 6385: #             known parameters.
 6386: #
 6387: # Entry:      $params - hashref of parameters
 6388: #                       (modified in place).
 6389: #             $code   - method body source string.
 6390: #             $method - method hashref, used for
 6391: #                       constructor-specific
 6392: #                       exclusions of $class and
 6393: #                       $self.
 6394: #
 6395: # Exit:       Returns nothing. Modifies $params
 6396: #             in place.
 6397: #
 6398: # Side effects: Logs detections to stdout when
 6399: #               verbose is set.
 6400: #
 6401: # Notes:      Eight default patterns are tried.
 6402: #             Only parameters already present in
 6403: #             $params are updated — this method
 6404: #             does not add new parameters.
 6405: #             Falls back to extracting all @_
 6406: #             assignments if $params is empty
 6407: #             after the main pass.
 6408: # --------------------------------------------------
 6409: sub _extract_defaults_from_code {
●6410 → 6413 → 6424 6410: 	my ($self, $params, $code, $method) = @_;
 6411: 
 6412: 	# Pattern 1: my $param = value;
 6413: 	while ($code =~ /my\s+\$(\w+)\s*=\s*([^;]+);/g) {
 6414: 		my ($param, $value) = ($1, $2);
 6415: 		next unless exists $params->{$param};
 6416: 		next if $value =~ /->/;	# deref/method call, not a default value
 6417: 
 6418: 		$params->{$param}{_default} = $self->_clean_default_value($value, 1);
 6419: 		$params->{$param}{optional} = 1;
 6420: 		$self->_log("  CODE: $param has default: " . $self->_format_default($params->{$param}{_default}));
 6421: 	}
 6422: 
 6423: 	# Pattern 2: $param = value unless defined $param;
●6424 → 6424 → 6434 6424: 	while ($code =~ /\$(\w+)\s*=\s*([^;]+?)\s+unless\s+(?:defined\s+)?\$\1/g) {
 6425: 		my ($param, $value) = ($1, $2);
 6426: 		next unless exists $params->{$param};
 6427: 
 6428: 		$params->{$param}{_default} = $self->_clean_default_value($value, 1);
 6429: 		$params->{$param}{optional} = 1;
 6430: 		$self->_log("  CODE: $param has default (unless): " . $self->_format_default($params->{$param}{_default}));
 6431: 	}
 6432: 
 6433: 	# Pattern 3: $param = value unless $param;
●6434 → 6434 → 6444 6434: 	while ($code =~ /\$(\w+)\s*=\s*([^;]+?)\s+unless\s+\$\1/g) {
 6435: 		my ($param, $value) = ($1, $2);
 6436: 		next unless exists $params->{$param};
 6437: 
 6438: 		$params->{$param}{_default} = $self->_clean_default_value($value, 1);
 6439: 		$params->{$param}{optional} = 1;
 6440: 		$self->_log("  CODE: $param has default (unless): " . $self->_format_default($params->{$param}{_default}));
 6441: 	}
 6442: 
 6443: 	# Pattern 4: $param = $param || 'default';
●6444 → 6444 → 6454 6444: 	while ($code =~ /\$(\w+)\s*=\s*\$\1\s*\|\|\s*([^;]+);/g) {
 6445: 		my ($param, $value) = ($1, $2);
 6446: 		next unless exists $params->{$param};
 6447: 
 6448: 		$params->{$param}{_default} = $self->_clean_default_value($value, 1);
 6449: 		$params->{$param}{optional} = 1;
 6450: 		$self->_log("  CODE: $param has default (||): " . $self->_format_default($params->{$param}{_default}));
 6451: 	}
 6452: 
 6453: 	# Pattern 5: $param ||= 'default';
●6454 → 6454 → 6464 6454: 	while ($code =~ /\$(\w+)\s*\|\|=\s*([^;]+);/g) {
 6455: 		my ($param, $value) = ($1, $2);
 6456: 		next unless exists $params->{$param};
 6457: 
 6458: 		$params->{$param}{_default} = $self->_clean_default_value($value, 1);
 6459: 		$params->{$param}{optional} = 1;
 6460: 		$self->_log("  CODE: $param has default (||=): " . $self->_format_default($params->{$param}{_default}));
 6461: 	}
 6462: 
 6463: 	# Pattern 6: $param //= 'default';
●6464 → 6464 → 6475 6464: 	while ($code =~ /\$(\w+)\s*\/\/=\s*([^;]+);/g) {
 6465: 		my ($param, $value) = ($1, $2);
 6466: 		next unless exists $params->{$param};  # Using -> because $params is a reference
 6467: 
 6468: 		$params->{$param}{_default} = $self->_clean_default_value($value, 1);
 6469: 
 6470: 		$params->{$param}{optional} = 1;
 6471: 		$self->_log("  CODE: $param has default (//=): " . $self->_format_default($params->{$param}{_default}));
 6472: 	}
 6473: 
 6474: 	# Pattern 7: $param = defined $param ? $param : 'default';
●6475 → 6475 → 6489 6475: 	while ($code =~ /\$(\w+)\s*=\s*defined\s+\$\1\s*\?\s*\$\1\s*:\s*([^;]+);/g) {
 6476: 		my ($param, $value) = ($1, $2);
 6477: 
 6478: 		# Create param entry if it doesn't exist
 6479: 		$params->{$param} ||= {};
 6480: 
 6481: 		my $cleaned = $self->_clean_default_value($value, 1);
 6482: 
 6483: 		$params->{$param}{_default} = $cleaned;
 6484: 		$params->{$param}{optional} = 1;
 6485: 		$self->_log("  CODE: $param has default (ternary): " . $self->_format_default($params->{$param}{_default}));
 6486: 	}
 6487: 
 6488: 	# Pattern 8: $param = $args{param} || 'default';
●6489 → 6489 → 6499 6489: 	while ($code =~ /\$(\w+)\s*=\s*\$args\{['"]?\w+['"]?\}\s*\|\|\s*([^;]+);/g) {
 6490: 		my ($param, $value) = ($1, $2);
 6491: 		next unless exists $params->{$param};
 6492: 
 6493: 		$params->{$param}{_default} = $self->_clean_default_value($value, 1);
 6494: 		$params->{$param}{optional} = 1;
 6495: 		$self->_log("  CODE: $param has default (from args): " . $self->_format_default($params->{$param}{_default}));
 6496: 	}
 6497: 
 6498: 	# Pattern for non-empty hashref
●6499 → 6499 → 6515 6499: 	while ($code =~ /\$(\w+)\s*\|\|=\s*\{[^}]+\}/gs) {
 6500: 		my $param = $1;
 6501: 		next unless exists $params->{$param};
 6502: 
 6503: 		# Return empty hashref as placeholder (can't evaluate complex hashrefs)
 6504: 		$params->{$param}{_default} = {};
 6505: 		$params->{$param}{optional} = 1;
 6506: 		$self->_log("  CODE: $param has hashref default (||=)");
 6507: 	}
 6508: 
 6509: 	# Fallback: extract parameters from classic Perl body styles
 6510: 	# Only run if signature extraction found nothing AND the code does not use
 6511: 	# the direct-index ($_[0]) style — that style is used for no-param methods
 6512: 	# whose empty %params would otherwise trigger this fallback and pick up
 6513: 	# my (...) = @_ from inner closures as if they were method params.
 6514: 	# TODO:  On constructors, use $class to help to determine the output type
●6515 → 6515 → 0 6515: 	if (!keys %{$params} && $code !~ /my\s+\$(?:self|class)\s*=\s*\$_\[0\]/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6516: 		my $position = 0;
 6517: 
 6518: 		# Style 1: my ($a, $b) = @_;
 6519: 		while ($code =~ /my\s*\(\s*([^)]+)\s*\)\s*=\s*\@_/g) {
 6520: 			my @vars = $1 =~ /\$(\w+)/g;
 6521: 			foreach my $var (@vars) {
 6522: 				if(($var eq 'class') && ($position == 0) && ($method->{name} eq 'new')) {

					

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

 6523: 					# Don't include "class" in the variable names of the constructor
 6524: 					delete $params->{'class'};
 6525: 				} elsif(($var eq 'self') && ($position == 0) && ($method->{name} ne 'new')) {

					

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

 6526: 					# Don't include "self" in the variable names
 6527: 					delete $params->{'self'};
 6528: 				} else {
 6529: 					$params->{$var} ||= { position => $position++ };
 6530: 					$self->_log("  CODE: $var extracted from \@_ list assignment");
 6531: 				}
 6532: 			}
 6533: 		}
 6534: 
 6535: 		# Style 2: my $x = shift;
 6536: 		while ($code =~ /my\s+\$(\w+)\s*=\s*shift\b/g) {
 6537: 			my $var = $1;
 6538: 			if(($var eq 'class') && ($position == 0) && ($method->{name} eq 'new')) {

					

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

 6539: 				# Don't include "class" in the variable names of the constructor
 6540: 				delete $params->{'class'};
 6541: 			} elsif(($var eq 'self') && ($position == 0) && ($method->{name} ne 'new')) {

					

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

 6542: 				# Don't include "self" in the variable names
 6543: 				delete $params->{'self'};
 6544: 			} else {
 6545: 				$params->{$var} ||= { position => $position++ };
 6546: 				$self->_log("  CODE: $var is extracted from shift");
 6547: 			}
 6548: 		}
 6549: 
 6550: 		# Style 3: my $x = $_[0];
 6551: 		while ($code =~ /my\s+\$(\w+)\s*=\s*\$_\[(\d+)\]/g) {
 6552: 			my ($var, $index) = ($1, $2);
 6553: 			if(($var ne 'class') || ($position > 0) || ($method->{name} ne 'new')) {

					

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

 6554: 				$params->{$var} ||= { position => $index };
 6555: 				$self->_log("  CODE: $var is extracted from \$_\[$index\]");
 6556: 			}
 6557: 		}
 6558: 	}
 6559: }
 6560: 
 6561: # --------------------------------------------------
 6562: # _format_default
 6563: #
 6564: # Purpose:    Format a default value for display
 6565: #             in verbose log output.
 6566: #
 6567: # Entry:      $default - the default value to
 6568: #                        format. May be undef,
 6569: #                        a scalar, a hashref, or
 6570: #                        an arrayref.
 6571: #
 6572: # Exit:       Returns a display string: 'undef'
 6573: #             for undef, 'HASH ref' / 'ARRAY ref'
 6574: #             for references, or the value itself
 6575: #             for scalars.
 6576: #
 6577: # Side effects: None.
 6578: # --------------------------------------------------
 6579: sub _format_default {
 6580: 	my ($self, $default) = @_;
 6581: 	return 'undef' unless defined $default;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 6582: 	return ref($default) . ' ref' if ref($default);

  Mutants (Total: 2, Killed: 2, Survived: 0)
 6583: 	return $default;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 6584: }
 6585: 
 6586: # --------------------------------------------------
 6587: # _analyze_parameter_constraints
 6588: #
 6589: # Purpose:    Infer min, max, and regex match
 6590: #             constraints for a single parameter
 6591: #             from length checks, numeric
 6592: #             comparisons, and regex match
 6593: #             patterns in the method body.
 6594: #
 6595: # Entry:      $p_ref - reference to the parameter
 6596: #                      hashref (modified in place).
 6597: #             $param - parameter name string.
 6598: #             $code  - method body source string.
 6599: #
 6600: # Exit:       Returns nothing. Modifies the
 6601: #             referenced parameter hashref.
 6602: #
 6603: # Side effects: Logs detections to stdout when
 6604: #               verbose is set.
 6605: #
 6606: # Notes:      Numeric comparisons that appear
 6607: #             inside die/croak guard conditions
 6608: #             are excluded to avoid inferring
 6609: #             invalid-input ranges as valid
 6610: #             constraints.
 6611: # --------------------------------------------------
 6612: sub _analyze_parameter_constraints {
●6613 → 6618 → 6623 6613: 	my ($self, $p_ref, $param, $code) = @_;
 6614: 	my $p = $$p_ref;
 6615: 
 6616: 	# Do not treat comparisons inside die/croak/confess as valid constraints
 6617: 	my $guarded = 0;
 6618: 		if ($code =~ /(die|croak|confess)\b[^{;]*\bif\b[^{;]*\$$param\b/s) {

					

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

 6619: 		$guarded = 1;
 6620: 	}
 6621: 
 6622: 	# Length checks for strings
●6623 → 6623 → 6639 6623: 	if ($code =~ /length\s*\(\s*\$$param\s*\)\s*([<>]=?)\s*(\d+)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6624: 		my ($op, $val) = ($1, $2);
 6625: 		$p->{type} ||= 'string';
 6626: 		if ($op eq '<') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6627: 			$p->{max} = $val - 1;
 6628: 		} elsif ($op eq '<=') {
 6629: 			$p->{max} = $val;
 6630: 		} elsif ($op eq '>') {
 6631: 			$p->{min} = $val + 1;
 6632: 		} elsif ($op eq '>=') {
 6633: 			$p->{min} = $val;
 6634: 		}
 6635: 		$self->_log("  CODE: $param length constraint $op $val");
 6636: 	}
 6637: 
 6638: 	# Numeric range checks (only if NOT part of error guard)
●6639 → 6639 → 6657 6639: 	if (

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6640: 		!$guarded
 6641: 		&& $code =~ /\$$param\s*([<>]=?)\s*([+-]?(?:\d+\.?\d*|\.\d+))/
 6642: 	) {
 6643: 		my ($op, $val) = ($1, $2);
 6644: 		$p->{type} ||= looks_like_number($val) ? 'number' : 'integer';
 6645: 
 6646: 		if ($op eq '<' || $op eq '<=') {

					

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

 6647: 			# Only set max if it tightens the range
 6648: 			my $max = ($op eq '<') ? $val - 1 : $val;
 6649: 			$p->{max} = $max if !defined($p->{max}) || $max < $p->{max};

					

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

 6650: 		} elsif ($op eq '>' || $op eq '>=') {
 6651: 			my $min = ($op eq '>') ? $val + 1 : $val;
 6652: 			$p->{min} = $min if !defined($p->{min}) || $min > $p->{min};

					

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

 6653: 		}
 6654: 	}
 6655: 
 6656: 	# Regex pattern matching with better capture
●6657 → 6657 → 0 6657: 	if ($code =~ /\$$param\s*=~\s*((?:qr?\/[^\/]+\/|\$[\w:]+|\$\{\w+\}))/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6658: 		my $pattern = $1;
 6659: 		$p->{type} ||= 'string';
 6660: 
 6661: 		# Clean up the pattern if it's a straightforward regex
 6662: 		if ($pattern =~ /^qr?\/([^\/]+)\/$/) {

					

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

 6663: 			$p->{matches} = "/$1/";
 6664: 		} else {
 6665: 			$p->{matches} = $pattern;
 6666: 		}
 6667: 		$self->_log("  CODE: $param matches pattern: $p->{matches}");
 6668: 	}
 6669: }
 6670: 
 6671: # --------------------------------------------------
 6672: # _analyze_parameter_validation
 6673: #
 6674: # Purpose:    Determine optionality and extract
 6675: #             default values for a single parameter
 6676: #             by analysing explicit required checks
 6677: #             (die/croak unless defined) and default
 6678: #             assignment patterns in the method body.
 6679: #
 6680: # Entry:      $p_ref - reference to the parameter
 6681: #                      hashref (modified in place).
 6682: #             $param - parameter name string.
 6683: #             $code  - method body source string.
 6684: #
 6685: # Exit:       Returns nothing. Modifies the
 6686: #             referenced parameter hashref.
 6687: #
 6688: # Side effects: Logs detections to stdout when
 6689: #               verbose is set.
 6690: #
 6691: # Notes:      Explicit required checks take highest
 6692: #             priority and override any default
 6693: #             value detected earlier.
 6694: # --------------------------------------------------
 6695: sub _analyze_parameter_validation {
●6696 → 6703 → 6708 6696: 	my ($self, $p_ref, $param, $code) = @_;
 6697: 	my $p = $$p_ref;
 6698: 
 6699: 	# Required/optional checks
 6700: 	my $is_required = 0;
 6701: 
 6702: 	# Die/croak if not defined
 6703: 	if ($code =~ /(?:die|croak|confess)\s+[^;]*unless\s+(?:defined\s+)?\$$param/s) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6704: 		$is_required = 1;
 6705: 	}
 6706: 
 6707: 	# Extract default values with the new method
●6708 → 6709 → 6733 6708: 	my $default_value = $self->_extract_default_value($param, $code);
 6709: 	if (defined $default_value && !exists $p->{_default}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6710: 		$p->{optional} = 1;
 6711: 		$p->{_default} = $default_value;
 6712: 
 6713: 		# Try to infer type from default value if not already set
 6714: 		unless ($p->{type}) {

					

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

 6715: 			if (looks_like_number($default_value)) {

					

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

 6716: 				$p->{type} = $default_value =~ /\./ ? 'number' : 'integer';
 6717: 			} elsif (ref($default_value) eq 'ARRAY') {
 6718: 				$p->{type} = 'arrayref';
 6719: 			} elsif (ref($default_value) eq 'HASH') {
 6720: 				$p->{type} = 'hashref';
 6721: 			} elsif ($default_value eq 'undef') {
 6722: 				$p->{type} = 'scalar';	# undef can be any scalar
 6723: 			} elsif (defined $default_value && !ref($default_value)) {
 6724: 				$p->{type} = 'string';
 6725: 			}
 6726: 		}
 6727: 
 6728: 		$self->_log("  CODE: $param has default value: " . (ref($default_value) ? ref($default_value) . ' ref' : $default_value));
 6729: 	}
 6730: 
 6731: 	# Also check for simple default assignment without condition
 6732: 	# Pattern: $param = 'value';
●6733 → 6733 → 6749 6733: 	if (!$default_value && !exists $p->{_default} && $code =~ /\$$param\s*=\s*([^;{}]+?)(?:\s*[;}])/s) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6734: 		my $assignment = $1;
 6735: 		# Make sure it's not part of a larger expression
 6736: 		if ($assignment !~ /\$$param/ && $assignment !~ /^shift/) {

					

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

 6737: 			my $possible_default = $assignment;
 6738: 			$possible_default =~ s/\s*;\s*$//;
 6739: 			$possible_default = $self->_clean_default_value($possible_default);
 6740: 			if (defined $possible_default) {

					

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

 6741: 				$p->{_default} = $possible_default;
 6742: 				$p->{optional} = 1;
 6743: 				$self->_log("  CODE: $param has unconditional default: $possible_default");
 6744: 			}
 6745: 		}
 6746: 	}
 6747: 
 6748: 	# Explicit required check overrides default detection
●6749 → 6749 → 0 6749: 	if ($is_required) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6750: 		$p->{optional} = 0;
 6751: 		delete $p->{_default} if exists $p->{_default};
 6752: 		$self->_log("  CODE: $param is required (validation check)");
 6753: 	}
 6754: }
 6755: 
 6756: # --------------------------------------------------
 6757: # _merge_parameter_analyses
 6758: #
 6759: # Purpose:    Merge parameter information from POD,
 6760: #             code, and signature analysis into a
 6761: #             single authoritative parameter hashref
 6762: #             for each parameter.
 6763: #
 6764: # Entry:      $pod - hashref of parameters from POD
 6765: #                    analysis.
 6766: #             $code - hashref of parameters from
 6767: #                     code analysis.
 6768: #             $sig  - hashref of parameters from
 6769: #                     signature analysis (optional,
 6770: #                     defaults to empty hashref).
 6771: #
 6772: # Exit:       Returns a merged hashref of parameter
 6773: #             name to spec hashref. Each spec has
 6774: #             all available information combined,
 6775: #             with POD taking highest priority,
 6776: #             code second, and signature filling
 6777: #             remaining gaps.
 6778: #
 6779: # Side effects: Logs merged parameter details to
 6780: #               stdout when verbose is set.
 6781: #
 6782: # Notes:      Position is determined by majority
 6783: #             vote across all sources, with the
 6784: #             lowest position winning ties. Optional
 6785: #             status is determined by
 6786: #             _determine_optional_status. Internal
 6787: #             _source keys are stripped from the
 6788: #             merged result.
 6789: # --------------------------------------------------
 6790: sub _merge_parameter_analyses {
●6791 → 6798 → 6853 6791: 	my ($self, $pod, $code, $sig) = @_;
 6792: 
 6793: 	my %merged;
 6794: 
 6795: 	# Start with all parameters from all sources
 6796: 	my %all_params = map { $_ => 1 } (keys %$pod, keys %$code, keys %$sig);
 6797: 
 6798: 	foreach my $param (keys %all_params) {
 6799: 		my $p = $merged{$param} = {};
 6800: 
 6801: 		# Collect position from all sources
 6802: 		my @positions;
 6803: 		push @positions, $pod->{$param}{position} if $pod->{$param} && defined $pod->{$param}{position};
 6804: 		push @positions, $sig->{$param}{position} if $sig->{$param} && defined $sig->{$param}{position};
 6805: 		push @positions, $code->{$param}{position} if $code->{$param} && defined $code->{$param}{position};
 6806: 
 6807: 		# Use the most common position, or lowest if tie
 6808: 		if (@positions) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6809: 			my %pos_count;
 6810: 			$pos_count{$_}++ for @positions;
 6811: 			my ($best_pos) = sort { $pos_count{$b} <=> $pos_count{$a} || $a <=> $b } keys %pos_count;
 6812: 			$p->{position} = $best_pos unless(exists($p->{position}));
 6813: 		}
 6814: 
 6815: 		# POD has highest priority for type info and explicit declarations
 6816: 		if ($pod->{$param}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6817: 			%$p = (%$p, %{$pod->{$param}});
 6818: 		}
 6819: 
 6820: 		# Code analysis adds concrete evidence (but doesn't override POD explicit types)
 6821: 		if ($code->{$param}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6822: 			foreach my $key (keys %{$code->{$param}}) {
 6823: 				next if $key eq '_source';
 6824: 				next if $key eq 'position';
 6825: 
 6826: 				# Only override if POD didn't provide this info or it's a stronger signal
 6827: 				my $from_pod = exists $pod->{$param};
 6828: 				if (!exists $p->{$key} ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6829: 				   ($key eq 'type' && $from_pod && $p->{type} eq 'string' &&
 6830: 				   $code->{$param}{$key} ne 'string')) {
 6831: 					$p->{$key} = $code->{$param}{$key};
 6832: 				}
 6833: 			}
 6834: 		}
 6835: 
 6836: 		# Signature fills in remaining gaps
 6837: 		if ($sig->{$param}) {

					

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

 6838: 			foreach my $key (keys %{$sig->{$param}}) {
 6839: 				next if $key eq '_source';
 6840: 				next if $key eq 'position';
 6841: 				$p->{$key} //= $sig->{$param}{$key};
 6842: 			}
 6843: 		}
 6844: 
 6845: 		# Handle optional field with better logic
 6846: 		$self->_determine_optional_status($p, $pod->{$param}, $code->{$param});
 6847: 
 6848: 		# Clean up internal fields
 6849: 		delete $p->{_source};
 6850: 	}
 6851: 
 6852: 	# Debug logging
●6853 → 6853 → 6863 6853: 	if ($self->{verbose}) {

					

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

 6854: 		foreach my $param (sort { ($merged{$a}{position} || 999) <=> ($merged{$b}{position} || 999) } keys %merged) {
 6855: 			my $p = $merged{$param};
 6856: 			$self->_log("  MERGED $param: " .
 6857: 					'pos=' . ($p->{position} || 'none') .
 6858: 					", type=" . ($p->{type} || 'none') .
 6859: 					", optional=" . (defined($p->{optional}) ? $p->{optional} : 'undef'));
 6860: 		}
 6861: 	}
 6862: 
 6863: 	return \%merged;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 6864: }
 6865: 
 6866: # --------------------------------------------------
 6867: # _determine_optional_status
 6868: #
 6869: # Purpose:    Set the optional field on a merged
 6870: #             parameter spec based on evidence from
 6871: #             POD and code analysis, with POD taking
 6872: #             highest priority.
 6873: #
 6874: # Entry:      $merged_param - the merged parameter
 6875: #                             hashref (modified in
 6876: #                             place).
 6877: #             $pod_param    - parameter spec from
 6878: #                             POD analysis, or undef.
 6879: #             $code_param   - parameter spec from
 6880: #                             code analysis, or undef.
 6881: #
 6882: # Exit:       Returns nothing. Sets or leaves
 6883: #             $merged_param->{optional}.
 6884: #
 6885: # Side effects: None.
 6886: # --------------------------------------------------
 6887: sub _determine_optional_status {
●6888 → 6894 → 0 6888: 	my ($self, $merged_param, $pod_param, $code_param) = @_;
 6889: 
 6890: 	my $pod_optional = $pod_param ? $pod_param->{optional} : undef;
 6891: 	my $code_optional = $code_param ? $code_param->{optional} : undef;
 6892: 
 6893: 	# Explicit POD declaration wins
 6894: 	if (defined $pod_optional) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 6895: 		$merged_param->{optional} = $pod_optional;
 6896: 	}
 6897: 	# Code validation evidence
 6898: 	elsif (defined $code_optional) {
 6899: 		$merged_param->{optional} = $code_optional;
 6900: 	}
 6901: 	# Default: if we have any info about the param, assume required
 6902: 	elsif (keys %$merged_param > 0) {

  Mutants (Total: 3, Killed: 3, Survived: 0)
 6903: 		$merged_param->{optional} = 0;
 6904: 	}
 6905: 	# Otherwise leave undef (unknown)
 6906: }
 6907: 
 6908: 
 6909: # --------------------------------------------------
 6910: # _calculate_input_confidence
 6911: #
 6912: # Purpose:    Calculate a confidence score and level
 6913: #             for the input parameter analysis,
 6914: #             based on how much type, constraint,
 6915: #             and semantic information was inferred
 6916: #             for each parameter.
 6917: #
 6918: # Entry:      $params - hashref of merged parameter
 6919: #                       specs as produced by
 6920: #                       _merge_parameter_analyses.
 6921: #
 6922: # Exit:       Returns a hashref with keys:
 6923: #               level         - one of: none,
 6924: #                               very_low, low,
 6925: #                               medium, high
 6926: #               score         - numeric average
 6927: #                               across all params
 6928: #               factors       - arrayref of
 6929: #                               human-readable
 6930: #                               factor strings
 6931: #               per_parameter - hashref of per-
 6932: #                               parameter score
 6933: #                               and factor detail
 6934: #             Returns { level => 'none', ... } if
 6935: #             no parameters were found.
 6936: #
 6937: # Side effects: None.
 6938: # --------------------------------------------------
 6939: sub _calculate_input_confidence {
●6940 → 6950 → 7020 6940: 	my ($self, $params) = @_;
 6941: 
 6942: 	my @factors;  # Track all confidence factors
 6943: 
 6944: 	return { level => 'none', factors => ['No parameters found'] } unless keys %$params;
 6945: 
 6946: 	my $total_score = 0;
 6947: 	my $count = 0;
 6948: 	my %param_details;	# Store per-parameter analysis
 6949: 
 6950: 	foreach my $param (keys %$params) {
 6951: 		my $p = $params->{$param};
 6952: 		my $score = 0;
 6953: 		my @param_factors;
 6954: 
 6955: 		# Type information
 6956: 		if ($p->{type}) {

					

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

 6957: 			if ($p->{type} eq 'string' && ($p->{min} || $p->{max} || $p->{matches})) {

					

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

 6958: 				$score += 25;
 6959: 				push @param_factors, "Type: constrained string (+25)";
 6960: 			} elsif ($p->{type} eq 'string') {
 6961: 				$score += 10;
 6962: 				push @param_factors, "Type: plain string (+10)";
 6963: 			} else {
 6964: 				$score += 30;
 6965: 				push @param_factors, "Type: $p->{type} (+30)";
 6966: 			}
 6967: 		} else {
 6968: 			push @param_factors, "No type information (-0)";
 6969: 		}
 6970: 
 6971: 		# Constraints
 6972: 		if (defined $p->{min}) {

					

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

 6973: 			$score += 15;
 6974: 			push @param_factors, 'Has min constraint (+15)';
 6975: 		}
 6976: 		if (defined $p->{max}) {

					

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

 6977: 			$score += 15;
 6978: 			push @param_factors, "Has max constraint (+15)";
 6979: 		}
 6980: 		if (defined $p->{optional}) {

					

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

 6981: 			$score += 20;
 6982: 			push @param_factors, "Optional/required explicitly defined (+20)";
 6983: 		}
 6984: 		if ($p->{matches}) {

					

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

 6985: 			$score += 20;
 6986: 			push @param_factors, 'Has regex pattern constraint (+20)';
 6987: 		}
 6988: 		if ($p->{isa}) {

					

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

 6989: 			$score += 25;
 6990: 			push @param_factors, "Specific class constraint: $p->{isa} (+25)";
 6991: 		}
 6992: 
 6993: 		# Position information
 6994: 		if (defined $p->{position}) {

					

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

 6995: 			$score += 10;
 6996: 			push @param_factors, "Position defined: $p->{position} (+10)";
 6997: 		}
 6998: 
 6999: 		# Default value
 7000: 		if (exists $p->{_default}) {

					

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

 7001: 			$score += 10;
 7002: 			push @param_factors, "Has default value (+10)";
 7003: 		}
 7004: 
 7005: 		# Semantic information
 7006: 		if ($p->{semantic}) {

					

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

 7007: 			$score += 15;
 7008: 			push @param_factors, "Semantic type: $p->{semantic} (+15)";
 7009: 		}
 7010: 
 7011: 		$param_details{$param} = {
 7012: 			score => $score,
 7013: 			factors => \@param_factors
 7014: 		};
 7015: 
 7016: 		$total_score += $score;
 7017: 		$count++;
 7018: 	}
 7019: 
●7020 → 7029 → 7042 7020: 	my $avg = $count ? ($total_score / $count) : 0;
 7021: 
 7022: 	# Build summary factors
 7023: 	push @factors, sprintf("Analyzed %d parameter%s", $count, $count == 1 ? '' : 's');

					

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

 7024: 	push @factors, sprintf("Average confidence score: %.1f", $avg);
 7025: 
 7026: 	# Add top contributing factors
 7027: 	my @sorted_params = sort { $param_details{$b}{score} <=> $param_details{$a}{score} } keys %param_details;
 7028: 
 7029: 	if (@sorted_params) {

					

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

 7030: 		my $highest = $sorted_params[0];
 7031: 		my $highest_score = $param_details{$highest}{score};
 7032: 		push @factors, sprintf("Highest scoring parameter: \$$highest (score: %d)", $highest_score);
 7033: 
 7034: 		if (@sorted_params > 1) {

					

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

 7035: 			my $lowest = $sorted_params[-1];
 7036: 			my $lowest_score = $param_details{$lowest}{score};
 7037: 			push @factors, sprintf("Lowest scoring parameter: \$$lowest (score: %d)", $lowest_score);
 7038: 		}
 7039: 	}
 7040: 
 7041: 	# Determine confidence level
●7042 → 7043 → 7057 7042: 	my $level;
 7043: 	if ($avg >= $CONFIDENCE_HIGH_THRESHOLD) {

					

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

 7044: 		$level = $LEVEL_HIGH;
 7045: 		push @factors, "High confidence: comprehensive type and constraint information";
 7046: 	} elsif ($avg >= $CONFIDENCE_MEDIUM_THRESHOLD) {

					

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

 7047: 		$level = $LEVEL_MEDIUM;
 7048: 		push @factors, "Medium confidence: some type or constraint information present";
 7049: 	} elsif ($avg >= $CONFIDENCE_LOW_THRESHOLD) {

					

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

 7050: 		$level = $LEVEL_LOW;
 7051: 		push @factors, "Low confidence: minimal type information";
 7052: 	} else {
 7053: 		$level = $LEVEL_VERY_LOW;
 7054: 		push @factors, "Very low confidence: little to no type information";
 7055: 	}
 7056: 
 7057: 	return {
 7058: 		level => $level,
 7059: 		score => $avg,
 7060: 		factors => \@factors,
 7061: 		per_parameter => \%param_details
 7062: 	};
 7063: }
 7064: 
 7065: # --------------------------------------------------
 7066: # _calculate_output_confidence
 7067: #
 7068: # Purpose:    Calculate a confidence score and level
 7069: #             for the output analysis based on how
 7070: #             much return type, value, class,
 7071: #             context, and error convention
 7072: #             information was determined.
 7073: #
 7074: # Entry:      $output - the output hashref as built
 7075: #                       by _analyze_output.
 7076: #
 7077: # Exit:       Returns a hashref with keys:
 7078: #               level   - one of: none, very_low,
 7079: #                         low, medium, high
 7080: #               score   - numeric confidence score
 7081: #               factors - arrayref of factor strings
 7082: #             Returns { level => 'none', ... } if
 7083: #             output is empty.
 7084: #
 7085: # Side effects: None.
 7086: # --------------------------------------------------
 7087: sub _calculate_output_confidence {
●7088 → 7097 → 7105 7088: 	my ($self, $output) = @_;
 7089: 
 7090: 	my @factors;
 7091: 
 7092: 	return { level => 'none', factors => ['No return information found'] } unless keys %$output;
 7093: 
 7094: 	my $score = 0;
 7095: 
 7096: 	# Type information
 7097: 	if ($output->{type}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7098: 		$score += 30;
 7099: 		push @factors, "Return type defined: $output->{type} (+30)";
 7100: 	} else {
 7101: 		push @factors, 'No return type information (-0)';
 7102: 	}
 7103: 
 7104: 	# Specific value known
●7105 → 7105 → 7111 7105: 	if (defined $output->{value}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7106: 		$score += 30;
 7107: 		push @factors, "Specific return value: $output->{value} (+30)";
 7108: 	}
 7109: 
 7110: 	# Class information for objects
●7111 → 7111 → 7117 7111: 	if ($output->{isa}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7112: 		$score += 30;
 7113: 		push @factors, "Returns specific class: $output->{isa} (+30)";
 7114: 	}
 7115: 
 7116: 	# Context-aware returns
●7117 → 7117 → 7130 7117: 	if ($output->{_context_aware}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7118: 		$score += 20;
 7119: 		push @factors, "Context-aware return (wantarray) (+20)";
 7120: 
 7121: 		if ($output->{_list_context}) {

					

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

 7122: 			push @factors, "  List context: $output->{_list_context}{type}";
 7123: 		}
 7124: 		if ($output->{_scalar_context}) {

					

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

 7125: 			push @factors, "  Scalar context: $output->{_scalar_context}{type}";
 7126: 		}
 7127: 	}
 7128: 
 7129: 	# Error handling information
●7130 → 7130 → 7136 7130: 	if ($output->{_error_return}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7131: 		$score += 15;
 7132: 		push @factors, "Error return convention documented: $output->{_error_return} (+15)";
 7133: 	}
 7134: 
 7135: 	# Success/failure pattern
●7136 → 7136 → 7142 7136: 	if ($output->{_success_failure_pattern}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7137: 		$score += 10;
 7138: 		push @factors, 'Success/failure pattern detected (+10)';
 7139: 	}
 7140: 
 7141: 	# Chainable methods
●7142 → 7142 → 7148 7142: 	if ($output->{_returns_self}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7143: 		$score += 15;
 7144: 		push @factors, "Chainable method (fluent interface) (+15)";
 7145: 	}
 7146: 
 7147: 	# Void context
●7148 → 7148 → 7154 7148: 	if ($output->{_void_context}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7149: 		$score += 20;
 7150: 		push @factors, "Void context method (no meaningful return) (+20)";
 7151: 	}
 7152: 
 7153: 	# Exception handling
●7154 → 7154 → 7159 7154: 	if ($output->{_error_handling} && $output->{_error_handling}{exception_handling}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7155: 		$score += 10;
 7156: 		push @factors, 'Exception handling present (+10)';
 7157: 	}
 7158: 
●7159 → 7163 → 7177 7159: 	push @factors, sprintf("Total output confidence score: %d", $score);
 7160: 
 7161: 	# Determine confidence level
 7162: 	my $level;
 7163: 	if ($score >= $CONFIDENCE_HIGH_THRESHOLD) {

					

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

 7164: 		$level = $LEVEL_HIGH;
 7165: 		push @factors, "High confidence: detailed return type and behavior";
 7166: 	} elsif ($score >= $CONFIDENCE_MEDIUM_THRESHOLD) {

					

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

 7167: 		$level = $LEVEL_MEDIUM;
 7168: 		push @factors, "Medium confidence: return type defined";
 7169: 	} elsif ($score >= $CONFIDENCE_LOW_THRESHOLD) {

					

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

 7170: 		$level = $LEVEL_LOW;
 7171: 		push @factors, "Low confidence: minimal return information";
 7172: 	} else {
 7173: 		$level = $LEVEL_VERY_LOW;
 7174: 		push @factors, 'Very low confidence: little return information';
 7175: 	}
 7176: 
 7177: 	return {
 7178: 		level => $level,
 7179: 		score => $score,
 7180: 		factors => \@factors
 7181: 	};
 7182: }
 7183: 
 7184: # --------------------------------------------------
 7185: # _generate_confidence_report
 7186: #
 7187: # Purpose:    Generate a human-readable text report
 7188: #             of all confidence factors for a
 7189: #             schema, for debugging and review
 7190: #             purposes.
 7191: #
 7192: # Entry:      $schema - schema hashref containing
 7193: #                       a populated _analysis key.
 7194: #
 7195: # Exit:       Returns a multi-line string report,
 7196: #             or nothing if $schema->{_analysis}
 7197: #             is absent.
 7198: #
 7199: # Side effects: None.
 7200: # --------------------------------------------------
 7201: sub _generate_confidence_report
 7202: {
●7203 → 7217 → 7228 7203: 	my ($self, $schema) = @_;
 7204: 
 7205: 	return unless $schema->{_analysis};
 7206: 
 7207: 	my $analysis = $schema->{_analysis};
 7208: 	my @report;
 7209: 
 7210: 	push @report, "Confidence Analysis for " . ($schema->{method_name} || 'method');
 7211: 	push @report, '=' x 60;
 7212: 	push @report, '';
 7213: 
 7214: 	push @report, "Overall Confidence: " . uc($analysis->{overall_confidence});
 7215: 	push @report, '';
 7216: 
 7217: 	if ($analysis->{confidence_factors}{input}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7218: 		push @report, (
 7219: 			"Input Parameters:",
 7220: 			 "  Confidence Level: " . uc($analysis->{input_confidence})
 7221: 		);
 7222: 		foreach my $factor (@{$analysis->{confidence_factors}{input}}) {
 7223: 			push @report, "  - $factor";
 7224: 		}
 7225: 		push @report, '';
 7226: 	}
 7227: 
●7228 → 7228 → 7237 7228: 	if ($analysis->{confidence_factors}{output}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7229: 		push @report, 'Return Value:',
 7230: 			"  Confidence Level: " . uc($analysis->{output_confidence});
 7231: 		foreach my $factor (@{$analysis->{confidence_factors}{output}}) {
 7232: 			push @report, "  - $factor";
 7233: 		}
 7234: 		push @report, '';
 7235: 	}
 7236: 
●7237 → 7237 → 7249 7237: 	if ($analysis->{per_parameter_scores}) {

					

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

 7238: 		push @report, 'Per-Parameter Analysis:';
 7239: 		foreach my $param (sort keys %{$analysis->{per_parameter_scores}}) {
 7240: 			my $details = $analysis->{per_parameter_scores}{$param};
 7241: 			push @report, "  \$$param (score: $details->{score}):";
 7242: 			foreach my $factor (@{$details->{factors}}) {
 7243: 				push @report, "    - $factor";
 7244: 			}
 7245: 		}
 7246: 		push @report, '';
 7247: 	}
 7248: 
 7249: 	return join("\n", @report);

  Mutants (Total: 2, Killed: 2, Survived: 0)
 7250: }
 7251: 
 7252: # --------------------------------------------------
 7253: # _generate_notes
 7254: #
 7255: # Purpose:    Generate human-readable advisory notes
 7256: #             about parameters whose type or
 7257: #             optionality could not be determined,
 7258: #             to guide manual schema review.
 7259: #
 7260: # Entry:      $params - hashref of merged parameter
 7261: #                       specs.
 7262: #
 7263: # Exit:       Returns an arrayref of note strings.
 7264: #             Returns an empty arrayref if all
 7265: #             parameters have known types and
 7266: #             optionality.
 7267: #
 7268: # Side effects: None.
 7269: # --------------------------------------------------
 7270: sub _generate_notes {
●7271 → 7275 → 7288 7271: 	my ($self, $params) = @_;
 7272: 
 7273: 	my @notes;
 7274: 
 7275: 	foreach my $param (keys %$params) {
 7276: 		my $p = $params->{$param};
 7277: 
 7278: 		unless ($p->{type}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7279: 			push @notes, "$param: type unknown - please review - will set to 'string' as a default";
 7280: 		}
 7281: 
 7282: 		unless (defined $p->{optional}) {

					

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

 7283: 			push @notes, "$param: optional status unknown";
 7284: 			# Don't automatically set - let it be undef if we don't know
 7285: 		}
 7286: 	}
 7287: 
 7288: 	return \@notes;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 7289: }
 7290: 
 7291: # --------------------------------------------------
 7292: # _set_defaults
 7293: #
 7294: # Purpose:    Apply default type values to any
 7295: #             parameters in a schema mode (input
 7296: #             or output) whose type was not set
 7297: #             during analysis, setting them to
 7298: #             'string' as a conservative fallback.
 7299: #
 7300: # Entry:      $schema - the schema hashref being
 7301: #                       built by _analyze_method.
 7302: #             $mode   - either 'input' or 'output'.
 7303: #
 7304: # Exit:       Returns nothing. Modifies $schema in
 7305: #             place by setting type => 'string' on
 7306: #             any parameter that lacks a type, and
 7307: #             downgrading input confidence to 'low'.
 7308: #
 7309: # Side effects: Logs type defaulting to stdout when
 7310: #               verbose is set.
 7311: #
 7312: # Notes:      Called after all analysis is complete
 7313: #             so that genuine type unknowns can be
 7314: #             distinguished from analysis gaps.
 7315: # --------------------------------------------------
 7316: sub _set_defaults {
●7317 → 7321 → 0 7317: 	my ($self, $schema, $mode) = @_;
 7318: 
 7319: 	my $params = $schema->{$mode};
 7320: 
 7321: 	foreach my $param (keys %$params) {
 7322: 		my $p = $params->{$param};
 7323: 
 7324: 		next unless(ref($p) eq 'HASH');
 7325: 		unless ($p->{type}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7326: 			$self->_log("  DEBUG {$mode}{$param}: Setting to 'string' as a default");
 7327: 			$p->{'type'} = 'string';
 7328: 			$schema->{_confidence}{$mode}->{level} = 'low';	# Setting a default means it's a guess
 7329: 		}
 7330: 	}
 7331: }
 7332: 
 7333: # --------------------------------------------------
 7334: # _analyze_relationships
 7335: #
 7336: # Purpose:    Detect inter-parameter relationships
 7337: #             in a method's source code, including
 7338: #             mutually exclusive parameters, required
 7339: #             groups, conditional requirements,
 7340: #             dependencies, and value-based
 7341: #             constraints.
 7342: #
 7343: # Entry:      $method - method hashref containing
 7344: #                       at minimum a 'body' key
 7345: #                       with the source string.
 7346: #
 7347: # Exit:       Returns an arrayref of relationship
 7348: #             hashrefs. Returns an empty arrayref
 7349: #             if no parameters or no relationships
 7350: #             are found.
 7351: #
 7352: # Side effects: Logs detections to stdout when
 7353: #               verbose is set.
 7354: #
 7355: # Notes:      Parameter names are extracted via
 7356: #             _extract_parameters_from_signature, so
 7357: #             every style it supports -- my (...) =
 7358: #             @_, shift-style (my $x = shift), direct-
 7359: #             index ($_[N]), and modern signatures --
 7360: #             is analysed for relationships, not just
 7361: #             the my (...) = @_ list-assignment form.
 7362: # --------------------------------------------------
 7363: sub _analyze_relationships {
 7364: 	my ($self, $method) = @_;
 7365: 
 7366: 	my $code = $method->{body};
 7367: 	my @relationships;
 7368: 
 7369: 	# Extract all parameter names from the method, using the same
 7370: 	# multi-style detection used for schema population so shift-style
 7371: 	# and modern-signature methods get relationship analysis too
 7372: 	my %params;
 7373: 	$self->_extract_parameters_from_signature(\%params, $code);
 7374: 	my @param_names = sort { $params{$a}{position} <=> $params{$b}{position} } keys %params;
 7375: 
 7376: 	return [] unless @param_names;
 7377: 
 7378: 	# Detect mutually exclusive parameters
 7379: 	push @relationships, @{$self->_detect_mutually_exclusive($code, \@param_names)};
 7380: 
 7381: 	# Detect required groups (OR logic)
 7382: 	push @relationships, @{$self->_detect_required_groups($code, \@param_names)};
 7383: 
 7384: 	# Detect conditional requirements (IF-THEN)
 7385: 	push @relationships, @{$self->_detect_conditional_requirements($code, \@param_names)};
 7386: 
 7387: 	# Detect dependencies
 7388: 	push @relationships, @{$self->_detect_dependencies($code, \@param_names)};
 7389: 
 7390: 	# Detect value-based constraints
 7391: 	push @relationships, @{$self->_detect_value_constraints($code, \@param_names)};
 7392: 
 7393: 	# Deduplicate relationships
 7394: 	my @unique = $self->_deduplicate_relationships(\@relationships);
 7395: 
 7396: 	return \@unique;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 7397: }
 7398: 
 7399: # --------------------------------------------------
 7400: # _deduplicate_relationships
 7401: #
 7402: # Purpose:    Remove duplicate relationship entries
 7403: #             from the relationships list by
 7404: #             computing a canonical signature for
 7405: #             each relationship type.
 7406: #
 7407: # Entry:      $relationships - arrayref of
 7408: #                              relationship hashrefs.
 7409: #
 7410: # Exit:       Returns a deduplicated list of
 7411: #             relationship hashrefs.
 7412: #
 7413: # Side effects: None.
 7414: # --------------------------------------------------
 7415: sub _deduplicate_relationships {
●7416 → 7421 → 7445 7416: 	my ($self, $relationships) = @_;
 7417: 
 7418: 	my @unique;
 7419: 	my %seen;
 7420: 
 7421: 	foreach my $rel (@$relationships) {
 7422: 		# Create a signature for this relationship
 7423: 		my $sig;
 7424: 		if ($rel->{type} eq 'mutually_exclusive') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7425: 			$sig = join(':', 'mutex', sort @{$rel->{params}});
 7426: 		} elsif ($rel->{type} eq 'required_group') {
 7427: 			$sig = join(':', 'reqgroup', sort @{$rel->{params}});
 7428: 		} elsif ($rel->{type} eq 'conditional_requirement') {
 7429: 			$sig = join(':', 'condreq', $rel->{if}, $rel->{then_required});
 7430: 		} elsif ($rel->{type} eq 'dependency') {
 7431: 			$sig = join(':', 'dep', $rel->{param}, $rel->{requires});
 7432: 		} elsif ($rel->{type} eq 'value_constraint') {
 7433: 			$sig = join(':', 'valcon', $rel->{if}, $rel->{then}, $rel->{operator}, $rel->{value});
 7434: 		} elsif ($rel->{type} eq 'value_conditional') {
 7435: 			$sig = join(':', 'valcond', $rel->{if}, $rel->{equals}, $rel->{then_required});
 7436: 		} else {
 7437: 			$sig = join(':', $rel->{type}, %$rel);
 7438: 		}
 7439: 
 7440: 		unless ($seen{$sig}++) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7441: 			push @unique, $rel;
 7442: 		}
 7443: 	}
 7444: 
 7445: 	return @unique;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 7446: }
 7447: 
 7448: # --------------------------------------------------
 7449: # _detect_mutually_exclusive
 7450: #
 7451: # Purpose:    Detect pairs of parameters that cannot
 7452: #             be specified together, by searching
 7453: #             for die/croak/confess patterns
 7454: #             that fire when both are truthy.
 7455: #
 7456: # Entry:      $code        - method body source string.
 7457: #             $param_names - arrayref of parameter
 7458: #                            name strings.
 7459: #
 7460: # Exit:       Returns an arrayref of relationship
 7461: #             hashrefs of type 'mutually_exclusive'.
 7462: #             Returns an empty arrayref if none found.
 7463: #
 7464: # Side effects: Logs detections to stdout when
 7465: #               verbose is set.
 7466: # --------------------------------------------------
 7467: sub _detect_mutually_exclusive {
●7468 → 7474 → 7529 7468: 	my ($self, $code, $param_names) = @_;
 7469: 
 7470: 	my @relationships;
 7471: 
 7472: 	# Pattern 1: die/croak if $x && $y
 7473: 	# Look for: die/croak ... if $param1 && $param2
 7474: 	foreach my $param1 (@$param_names) {
 7475: 		foreach my $param2 (@$param_names) {
 7476: 			next if $param1 eq $param2;
 7477: 
 7478: 			# Check various patterns
 7479: 			if ($code =~ /(?:die|croak|confess)[^;]*if\s+\$$param1\s+&&\s+\$$param2/ ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7480: 			    $code =~ /(?:die|croak|confess)[^;]*if\s+\$$param2\s+&&\s+\$$param1/) {
 7481: 
 7482: 				# Avoid duplicates (param1,param2 vs param2,param1)
 7483: 				my $found_reverse = 0;
 7484: 				foreach my $rel (@relationships) {
 7485: 					if ($rel->{type} eq 'mutually_exclusive' &&

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7486: 					    (($rel->{params}[0] eq $param2 && $rel->{params}[1] eq $param1))) {
 7487: 						$found_reverse = 1;
 7488: 						last;
 7489: 					}
 7490: 				}
 7491: 
 7492: 				next if $found_reverse;
 7493: 
 7494: 				push @relationships, {
 7495: 					type => 'mutually_exclusive',
 7496: 					params => [$param1, $param2],
 7497: 					description => "Cannot specify both $param1 and $param2"
 7498: 				};
 7499: 
 7500: 				$self->_log("  RELATIONSHIP: $param1 and $param2 are mutually exclusive");
 7501: 			}
 7502: 
 7503: 			# Pattern 2: die "Cannot specify both X and Y"
 7504: 			if ($code =~ /(?:die|croak|confess)\s+['"](Cannot|Can't)[^'"]*both[^'"]*$param1[^'"]*$param2/i ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7505: 			    $code =~ /(?:die|croak|confess)\s+['"](Cannot|Can't)[^'"]*both[^'"]*$param2[^'"]*$param1/i) {
 7506: 
 7507: 				my $found_reverse = 0;
 7508: 				foreach my $rel (@relationships) {
 7509: 					if ($rel->{type} eq 'mutually_exclusive' &&

					

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

 7510: 					    (($rel->{params}[0] eq $param2 && $rel->{params}[1] eq $param1))) {
 7511: 						$found_reverse = 1;
 7512: 						last;
 7513: 					}
 7514: 				}
 7515: 
 7516: 				next if $found_reverse;
 7517: 
 7518: 				push @relationships, {
 7519: 					type => 'mutually_exclusive',
 7520: 					params => [$param1, $param2],
 7521: 					description => "Cannot specify both $param1 and $param2"
 7522: 				};
 7523: 
 7524: 				$self->_log("  RELATIONSHIP: $param1 and $param2 are mutually exclusive (from error message)");
 7525: 			}
 7526: 		}
 7527: 	}
 7528: 
 7529: 	return \@relationships;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 7530: }
 7531: 
 7532: # --------------------------------------------------
 7533: # _detect_required_groups
 7534: #
 7535: # Purpose:    Detect parameter groups where at least
 7536: #             one parameter must be specified (OR
 7537: #             logic), by searching for die/croak
 7538: #             patterns that fire unless any of the
 7539: #             group is truthy.
 7540: #
 7541: # Entry:      $code        - method body source string.
 7542: #             $param_names - arrayref of parameter
 7543: #                            name strings.
 7544: #
 7545: # Exit:       Returns an arrayref of relationship
 7546: #             hashrefs of type 'required_group'.
 7547: #             Returns an empty arrayref if none found.
 7548: #
 7549: # Side effects: Logs detections to stdout when
 7550: #               verbose is set.
 7551: # --------------------------------------------------
 7552: sub _detect_required_groups {
●7553 → 7558 → 7614 7553: 	my ($self, $code, $param_names) = @_;
 7554: 
 7555: 	my @relationships;
 7556: 
 7557: 	# Pattern 1: die/croak unless $x || $y
 7558: 	foreach my $param1 (@$param_names) {
 7559: 		foreach my $param2 (@$param_names) {
 7560: 			next if $param1 eq $param2;
 7561: 
 7562: 			if ($code =~ /(?:die|croak|confess)[^;]*unless\s+\$$param1\s+\|\|\s+\$$param2/ ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7563: 			    $code =~ /(?:die|croak|confess)[^;]*unless\s+\$$param2\s+\|\|\s+\$$param1/) {
 7564: 
 7565: 				# Avoid duplicates
 7566: 				my $found_reverse = 0;
 7567: 				foreach my $rel (@relationships) {
 7568: 					if ($rel->{type} eq 'required_group' &&

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7569: 					    (($rel->{params}[0] eq $param2 && $rel->{params}[1] eq $param1))) {
 7570: 						$found_reverse = 1;
 7571: 						last;
 7572: 					}
 7573: 				}
 7574: 
 7575: 				next if $found_reverse;
 7576: 
 7577: 				push @relationships, {
 7578: 					type => 'required_group',
 7579: 					params => [$param1, $param2],
 7580: 					logic => 'or',
 7581: 					description => "Must specify either $param1 or $param2"
 7582: 				};
 7583: 
 7584: 				$self->_log("  RELATIONSHIP: Must specify either $param1 or $param2");
 7585: 			}
 7586: 
 7587: 			# Pattern 2: die "Must specify either X or Y"
 7588: 			if ($code =~ /(?:die|croak|confess)\s+['"]Must\s+specify\s+either[^'"]*$param1[^'"]*or[^'"]*$param2/i ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7589: 			    $code =~ /(?:die|croak|confess)\s+['"]Must\s+specify\s+either[^'"]*$param2[^'"]*or[^'"]*$param1/i) {
 7590: 
 7591: 				my $found_reverse = 0;
 7592: 				foreach my $rel (@relationships) {
 7593: 					if ($rel->{type} eq 'required_group' &&

					

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

 7594: 					    (($rel->{params}[0] eq $param2 && $rel->{params}[1] eq $param1))) {
 7595: 						$found_reverse = 1;
 7596: 						last;
 7597: 					}
 7598: 				}
 7599: 
 7600: 				next if $found_reverse;
 7601: 
 7602: 				push @relationships, {
 7603: 					type => 'required_group',
 7604: 					params => [$param1, $param2],
 7605: 					logic => 'or',
 7606: 					description => "Must specify either $param1 or $param2"
 7607: 				};
 7608: 
 7609: 				$self->_log("  RELATIONSHIP: Must specify either $param1 or $param2 (from error message)");
 7610: 			}
 7611: 		}
 7612: 	}
 7613: 
 7614: 	return \@relationships;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 7615: }
 7616: 
 7617: # --------------------------------------------------
 7618: # _detect_conditional_requirements
 7619: #
 7620: # Purpose:    Detect IF-THEN parameter relationships
 7621: #             where one parameter being present
 7622: #             makes another required, by searching
 7623: #             for die/croak patterns of the form
 7624: #             'die if $x && !$y'.
 7625: #
 7626: # Entry:      $code        - method body source string.
 7627: #             $param_names - arrayref of parameter
 7628: #                            name strings.
 7629: #
 7630: # Exit:       Returns an arrayref of relationship
 7631: #             hashrefs of type
 7632: #             'conditional_requirement'.
 7633: #             Returns an empty arrayref if none found.
 7634: #
 7635: # Side effects: Logs detections to stdout when
 7636: #               verbose is set.
 7637: # --------------------------------------------------
 7638: sub _detect_conditional_requirements {
●7639 → 7643 → 7685 7639: 	my ($self, $code, $param_names) = @_;
 7640: 
 7641: 	my @relationships;
 7642: 
 7643: 	foreach my $param1 (@$param_names) {
 7644: 		foreach my $param2 (@$param_names) {
 7645: 			next if $param1 eq $param2;
 7646: 
 7647: 			# Pattern 1: die if $x && !$y  (if x then y required)
 7648: 			if ($code =~ /(?:die|croak|confess)[^;]*if\s+\$$param1\s+&&\s+!\$$param2/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7649: 				push @relationships, {
 7650: 					type => 'conditional_requirement',
 7651: 					if => $param1,
 7652: 					then_required => $param2,
 7653: 					description => "When $param1 is specified, $param2 is required"
 7654: 				};
 7655: 
 7656: 				$self->_log("  RELATIONSHIP: $param1 requires $param2");
 7657: 			}
 7658: 
 7659: 			# Pattern 2: die if $x && !defined($y)
 7660: 			if ($code =~ /(?:die|croak|confess)[^;]*if\s+\$$param1\s+&&\s+!defined\s*\(\s*\$$param2\s*\)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7661: 				push @relationships, {
 7662: 					type => 'conditional_requirement',
 7663: 					if => $param1,
 7664: 					then_required => $param2,
 7665: 					description => "When $param1 is specified, $param2 is required"
 7666: 				};
 7667: 
 7668: 				$self->_log("  RELATIONSHIP: $param1 requires $param2 (defined check)");
 7669: 			}
 7670: 
 7671: 			# Pattern 3: Error message "X requires Y"
 7672: 			if ($code =~ /(?:die|croak|confess)\s+['"]\w*$param1[^'"]*requires[^'"]*$param2/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7673: 				push @relationships, {
 7674: 					type => 'conditional_requirement',
 7675: 					if => $param1,
 7676: 					then_required => $param2,
 7677: 					description => "When $param1 is specified, $param2 is required"
 7678: 				};
 7679: 
 7680: 				$self->_log("  RELATIONSHIP: $param1 requires $param2 (from error message)");
 7681: 			}
 7682: 		}
 7683: 	}
 7684: 
 7685: 	return \@relationships;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 7686: }
 7687: 
 7688: # --------------------------------------------------
 7689: # _detect_dependencies
 7690: #
 7691: # Purpose:    Detect simple parameter dependencies
 7692: #             where one parameter requires another
 7693: #             to also be present, by combining
 7694: #             error message pattern matching with
 7695: #             code condition matching.
 7696: #
 7697: # Entry:      $code        - method body source string.
 7698: #             $param_names - arrayref of parameter
 7699: #                            name strings.
 7700: #
 7701: # Exit:       Returns an arrayref of relationship
 7702: #             hashrefs of type 'dependency'.
 7703: #             Returns an empty arrayref if none found.
 7704: #
 7705: # Side effects: Logs detections to stdout when
 7706: #               verbose is set.
 7707: # --------------------------------------------------
 7708: sub _detect_dependencies {
●7709 → 7713 → 7734 7709: 	my ($self, $code, $param_names) = @_;
 7710: 
 7711: 	my @relationships;
 7712: 
 7713: 	foreach my $param1 (@$param_names) {
 7714: 		foreach my $param2 (@$param_names) {
 7715: 			next if $param1 eq $param2;
 7716: 
 7717: 			# Pattern 1: Error message mentions "X requires Y" AND code checks $x && !$y
 7718: 			# Split into two checks to be more flexible
 7719: 			if (($code =~ /(?:die|croak|confess)\s+['"]\w*$param1[^'"]*requires[^'"]*$param2/i) &&

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7720: 			    ($code =~ /if\s+\$$param1\s+&&\s+!\$$param2/)) {
 7721: 
 7722: 				push @relationships, {
 7723: 					type => 'dependency',
 7724: 					param => $param1,
 7725: 					requires => $param2,
 7726: 					description => "$param1 requires $param2 to be specified"
 7727: 				};
 7728: 
 7729: 				$self->_log("  RELATIONSHIP: $param1 depends on $param2");
 7730: 			}
 7731: 		}
 7732: 	}
 7733: 
 7734: 	return \@relationships;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 7735: }
 7736: 
 7737: # --------------------------------------------------
 7738: # _detect_value_constraints
 7739: #
 7740: # Purpose:    Detect value-based constraints between
 7741: #             parameters, such as 'if $ssl then
 7742: #             $port must equal 443' or 'if $mode
 7743: #             eq secure then $key is required'.
 7744: #
 7745: # Entry:      $code        - method body source string.
 7746: #             $param_names - arrayref of parameter
 7747: #                            name strings.
 7748: #
 7749: # Exit:       Returns an arrayref of relationship
 7750: #             hashrefs of type 'value_constraint'
 7751: #             or 'value_conditional'.
 7752: #             Returns an empty arrayref if none found.
 7753: #
 7754: # Side effects: Logs detections to stdout when
 7755: #               verbose is set.
 7756: # --------------------------------------------------
 7757: sub _detect_value_constraints {
●7758 → 7762 → 7812 7758: 	my ($self, $code, $param_names) = @_;
 7759: 
 7760: 	my @relationships;
 7761: 
 7762: 	foreach my $param1 (@$param_names) {
 7763: 		foreach my $param2 (@$param_names) {
 7764: 			next if $param1 eq $param2;
 7765: 
 7766: 			# Pattern 1: die if $x && $y != value
 7767: 			if ($code =~ /(?:die|croak|confess)[^;]*if\s+\$$param1\s+&&\s+\$$param2\s*!=\s*(\d+)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7768: 				my $value = $1;
 7769: 				push @relationships, {
 7770: 					type => 'value_constraint',
 7771: 					if => $param1,
 7772: 					then => $param2,
 7773: 					operator => '==',
 7774: 					value => $value,
 7775: 					description => "When $param1 is specified, $param2 must equal $value"
 7776: 				};
 7777: 
 7778: 				$self->_log("  RELATIONSHIP: $param1 requires $param2 == $value");
 7779: 			}
 7780: 
 7781: 			# Pattern 2: die if $x && $y < value
 7782: 			if ($code =~ /(?:die|croak|confess)[^;]*if\s+\$$param1\s+&&\s+\$$param2\s*<\s*(\d+)/) {

					

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

 7783: 				my $value = $1;
 7784: 				push @relationships, {
 7785: 					type => 'value_constraint',
 7786: 					if => $param1,
 7787: 					then => $param2,
 7788: 					operator => '>=',
 7789: 					value => $value,
 7790: 					description => "When $param1 is specified, $param2 must be >= $value"
 7791: 				};
 7792: 
 7793: 				$self->_log("  RELATIONSHIP: $param1 requires $param2 >= $value");
 7794: 			}
 7795: 
 7796: 			# Pattern 3: die if $x eq 'value' && !$y
 7797: 			if ($code =~ /(?:die|croak|confess)[^;]*if\s+\$$param1\s+eq\s+['"]([^'"]+)['"]\s+&&\s+!\$$param2/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7798: 				my $value = $1;
 7799: 				push @relationships, {
 7800: 					type => 'value_conditional',
 7801: 					if => $param1,
 7802: 					equals => $value,
 7803: 					then_required => $param2,
 7804: 					description => "When $param1 equals '$value', $param2 is required"
 7805: 				};
 7806: 
 7807: 				$self->_log("  RELATIONSHIP: $param1='$value' requires $param2");
 7808: 			}
 7809: 		}
 7810: 	}
 7811: 
 7812: 	return \@relationships;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 7813: }
 7814: 
 7815: # Write a single method schema to a YAML file in output_dir.
 7816: #
 7817: # Entry:      $method_name is a non-empty string; $schema is a hashref.
 7818: # Exit:       YAML file written to output_dir/$method_name.yml.
 7819: # Side effects: Creates output_dir if it does not exist.
 7820: # Notes:      Croaks if output_dir was not set in new().
 7821: 
 7822: sub _write_schema {
●7823 → 7838 → 7845 7823: 	my ($self, $method_name, $schema) = @_;
 7824: 
 7825: 	# output_dir is required here — croak early with a clear message
 7826: 	# rather than letting make_path fail with a cryptic error
 7827: 	croak(__PACKAGE__, ': output_dir must be provided to new() when writing schema files') unless defined $self->{output_dir};
 7828: 
 7829: 	make_path($self->{output_dir}) unless -d $self->{output_dir};
 7830: 
 7831: 	my $filename = "$self->{output_dir}/${method_name}.yml";
 7832: 
 7833: 	# Configure YAML::XS to not quote numeric strings
 7834: 	local $YAML::XS::QuoteNumericStrings = 0;
 7835: 
 7836: 	# Extract package name for module field
 7837: 	my $package_name = '';
 7838: 	if ($self->{_document}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7839: 		my $package_stmt = $self->{_document}->find_first('PPI::Statement::Package');
 7840: 		$package_name = $package_stmt ? $package_stmt->namespace : '';
 7841: 		$self->{_package_name} //= $package_name;
 7842: 	}
 7843: 
 7844: 	# Clean up schema for output - use the format expected by App::Test::Generator::Template
●7845 → 7860 → 7893 7845: 	my $output = {
 7846: 		function => $method_name,
 7847: 		module => $package_name,
 7848: 		config => {
 7849: 			close_stdin => 0,
 7850: 			dedup => 1,
 7851: 			test_nuls => 0,
 7852: 			test_undef => 0,
 7853: 			test_empty => 1,
 7854: 			test_non_ascii => 0,
 7855: 			test_security => 0
 7856: 		}
 7857: 	};
 7858: 
 7859: 	# Process input parameters with advanced type handling
 7860: 	if($schema->{'input'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7861: 		if(scalar(keys %{$schema->{'input'}})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7862: 			$output->{'input'} = {};
 7863: 
 7864: 			foreach my $param_name (keys %{$schema->{'input'}}) {
 7865: 				my $param = $schema->{'input'}{$param_name};
 7866: 				if($param->{name}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7867: 					my $name = delete $param->{name};
 7868: 					if($name ne $param_name) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7869: 						# Sanity check
 7870: 						croak("BUG: Parameter name - expected $param_name, got $name");
 7871: 					}
 7872: 				}
 7873: 				my $cleaned_param = $self->_serialize_parameter_for_yaml($param);
 7874: 				$output->{'input'}{$param_name} = $cleaned_param;
 7875: 			}
 7876: 
 7877: 			# If some params have positions and others don't, treat the whole
 7878: 			# input as a named (hash) API and strip all positions.  Mixed
 7879: 			# position state arises when a named-API method also happens to
 7880: 			# have a Params::Get positional-key call alongside =head4 Input
 7881: 			# named-block params that carry no position.
 7882: 			my @with_pos    = grep { defined $output->{input}{$_}{position} } keys %{$output->{input}};
 7883: 			my @without_pos = grep { !defined $output->{input}{$_}{position} } keys %{$output->{input}};
 7884: 			if (@with_pos && @without_pos) {

					

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

 7885: 				delete $output->{input}{$_}{position} for @with_pos;
 7886: 			}
 7887: 		} else {
 7888: 			delete $output->{input};
 7889: 		}
 7890: 	}
 7891: 
 7892: 	# Process output
●7893 → 7893 → 7900 7893: 	if($schema->{'output'} && (scalar(keys %{$schema->{'output'}}))) {

					

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

 7894: 		if((ref($schema->{output}{_error_handling}) eq 'HASH') && (scalar(keys %{$schema->{output}{_error_handling}}) == 0)) {

  Mutants (Total: 2, Killed: 2, Survived: 0)
 7895: 			delete $schema->{output}{_error_handling};
 7896: 		}
 7897: 		$output->{'output'} = $schema->{'output'};
 7898: 	}
 7899: 
●7900 → 7900 → 7906 7900: 	if($schema->{'output'}{'type'} && ($schema->{'output'}{'type'} eq 'scalar')) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7901: 		$schema->{'output'}{'type'} = 'string';
 7902: 		$schema->{_confidence}{output}->{level} = 'low';	# A guess
 7903: 	}
 7904: 
 7905: 	# Add 'new' field if object instantiation is needed
●7906 → 7906 → 7917 7906: 	if ($schema->{new}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7907: 		# TODO: consider allowing parent class packages up the ISA chain
 7908: 		if(ref($schema->{new}) || ($schema->{new} eq $package_name)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7909: 			$output->{new} = $schema->{new} eq $package_name ? undef : $schema->{'new'};
 7910: 		} else {
 7911: 			$self->_log("  NEW: Don't use $schema->{new} for object insantiation");
 7912: 			delete $schema->{new};
 7913: 			delete $output->{new};
 7914: 		}
 7915: 	}
 7916: 
●7917 → 7917 → 7920 7917: 	if(!defined($schema->{_confidence}{input}->{level})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7918: 		$schema->{_confidence}{input} = $self->_calculate_input_confidence($schema->{input});
 7919: 	}
●7920 → 7920 → 7925 7920: 	if(!defined($schema->{_confidence}{output}->{level})) {

					

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

 7921: 		$schema->{_confidence}{output} = $self->_calculate_output_confidence($schema->{output});
 7922: 	}
 7923: 
 7924: 	# Add relationships if detected
●7925 → 7925 → 7929 7925: 	if ($schema->{relationships} && @{$schema->{relationships}}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7926: 		$output->{relationships} = $schema->{relationships};
 7927: 	}
 7928: 
●7929 → 7929 → 7933 7929: 	if($schema->{accessor} && scalar(keys %{$schema->{accessor}})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7930: 		$output->{accessor} = $schema->{accessor};
 7931: 	}
 7932: 
 7933: 	open my $fh, '>', $filename;
 7934: 	print $fh YAML::XS::Dump($output);
 7935: 	print $fh $self->_generate_schema_comments($schema, $method_name);
 7936: 	close $fh;
 7937: 
 7938: 	my $rel_info = $schema->{relationships} ?
 7939: 		' [' . scalar(@{$schema->{relationships}}) . ' relationships]' : '';
 7940: 	$self->_log("  Wrote: $filename (input confidence: $schema->{_confidence}{input}->{level})" .
 7941: 				($schema->{new} ? " [requires: $schema->{new}]" : '') . $rel_info);
 7942: }
 7943: 
 7944: # --------------------------------------------------
 7945: # _generate_schema_comments
 7946: #
 7947: # Purpose:    Generate the YAML comment block
 7948: #             appended to the end of each written
 7949: #             schema file, containing provenance,
 7950: #             confidence levels, parameter type
 7951: #             notes, relationship summaries, and
 7952: #             warnings about types requiring
 7953: #             special test setup.
 7954: #
 7955: # Entry:      $schema      - the schema hashref as
 7956: #                            built by _analyze_method.
 7957: #             $method_name - the method name string,
 7958: #                            used in the fuzz
 7959: #                            command hint.
 7960: #
 7961: # Exit:       Returns a string of YAML comment lines
 7962: #             beginning with a blank line and ending
 7963: #             with a trailing newline.
 7964: #
 7965: # Side effects: None.
 7966: # --------------------------------------------------
 7967: sub _generate_schema_comments {
●7968 → 7980 → 8008 7968: 	my ($self, $schema, $method_name) = @_;
 7969: 
 7970: 	my @comments;
 7971: 
 7972: 	push @comments, '';
 7973: 	push @comments, '# Generated by ' . ref($self);
 7974: 	push @comments, "# Run: fuzz-harness-generator -r $self->{output_dir}/${method_name}.yml";
 7975: 	push @comments, '#';
 7976: 	push @comments, "# Input confidence: $schema->{_confidence}{input}->{level}";
 7977: 	push @comments, "# Output confidence: $schema->{_confidence}{output}->{level}";
 7978: 
 7979: 	# Add notes about parameters
 7980: 	if ($schema->{input}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7981: 		my @param_notes;
 7982: 		foreach my $param_name (sort keys %{$schema->{input}}) {
 7983: 			my $p = $schema->{input}{$param_name};
 7984: 
 7985: 			if ($p->{semantic}) {

					

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

 7986: 				push @param_notes, "$param_name: $p->{semantic}";
 7987: 			}
 7988: 
 7989: 			if ($p->{enum}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7990: 				push @param_notes, "$param_name: enum with " . scalar(@{$p->{enum}}) . " values";
 7991: 			}
 7992: 
 7993: 			if ($p->{isa}) {

					

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

 7994: 				push @param_notes, "$param_name: requires $p->{isa} object";
 7995: 			}
 7996: 		}
 7997: 
 7998: 		if (@param_notes) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 7999: 			push @comments, '#';
 8000: 			push @comments, '# Parameter types detected:';
 8001: 			foreach my $note (@param_notes) {
 8002: 				push @comments, "#   - $note";
 8003: 			}
 8004: 		}
 8005: 	}
 8006: 
 8007: 	# Add relationship notes
●8008 → 8008 → 8020 8008: 	if ($schema->{relationships} && @{$schema->{relationships}}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8009: 		push @comments, (
 8010: 			'#',
 8011: 			'# Parameter relationships detected:'
 8012: 		);
 8013: 		foreach my $rel (@{$schema->{relationships}}) {
 8014: 			my $desc = $rel->{description} || _format_relationship($rel);
 8015: 			push @comments, "#   - $desc";
 8016: 		}
 8017: 	}
 8018: 
 8019: 	# Add general notes
●8020 → 8020 → 8028 8020: 	if ($schema->{_notes} && scalar(@{$schema->{_notes}})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8021: 		push @comments, '#';
 8022: 		push @comments, '# Notes:';
 8023: 		foreach my $note (@{$schema->{_notes}}) {
 8024: 			push @comments, "#   - $note";
 8025: 		}
 8026: 	}
 8027: 
●8028 → 8028 → 8047 8028: 	if($schema->{_analysis}) {

					

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

 8029: 		push @comments, (
 8030: 			'#',
 8031: 			'# Analysis:',
 8032: 			'# TODO:',
 8033: 		);
 8034: 		# confidence_factors:
 8035: 		#   input:
 8036: 		#   - No parameters found
 8037: 		#   output:
 8038: 		#   - 'Return type defined: object (+30)'
 8039: 		#   - 'Total output confidence score: 30'
 8040: 		#   - 'Medium confidence: return type defined'
 8041: 		#   input_confidence: none
 8042: 		#   output_confidence: medium
 8043: 		#   overall_confidence: none
 8044: 	}
 8045: 
 8046: 	# Add warnings for complex types
●8047 → 8048 → 8066 8047: 	my @warnings;
 8048: 	if ($schema->{input}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8049: 		foreach my $param_name (keys %{$schema->{input}}) {
 8050: 			my $p = $schema->{input}{$param_name};
 8051: 
 8052: 			if ($p->{type} && $p->{type} eq 'coderef') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8053: 				push @warnings, "Parameter '$param_name' is a coderef - you'll need to provide a sub {} in tests";
 8054: 			}
 8055: 
 8056: 			if ($p->{semantic} && $p->{semantic} eq 'filehandle') {

					

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

 8057: 				push @warnings, "Parameter '$param_name' is a filehandle - consider using IO::String or mock";
 8058: 			}
 8059: 
 8060: 			if ($p->{isa} && $p->{isa} =~ /DateTime/) {

					

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

 8061: 				push @warnings, "Parameter '$param_name' requires DateTime - ensure DateTime is loaded";
 8062: 			}
 8063: 		}
 8064: 	}
 8065: 
●8066 → 8066 → 8074 8066: 	if (@warnings) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8067: 		push @comments, '#';
 8068: 		push @comments, '# WARNINGS - Manual test setup may be required:';
 8069: 		foreach my $warning (@warnings) {
 8070: 			push @comments, "#   ! $warning";
 8071: 		}
 8072: 	}
 8073: 
 8074: 	push @comments, '';
 8075: 
 8076: 	return join("\n", @comments);

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8077: }
 8078: 
 8079: # --------------------------------------------------
 8080: # _serialize_parameter_for_yaml
 8081: #
 8082: # Purpose:    Convert a parameter spec hashref into
 8083: #             a cleaned, YAML-serialisable form
 8084: #             suitable for App::Test::Generator
 8085: #             consumption, handling semantic type
 8086: #             mappings, enum values, and object
 8087: #             class annotations.
 8088: #
 8089: # Entry:      $param - parameter spec hashref as
 8090: #                      produced by the merge and
 8091: #                      analysis pipeline.
 8092: #
 8093: # Exit:       Returns a new hashref containing only
 8094: #             the fields App::Test::Generator
 8095: #             understands, with internal _ keys
 8096: #             and semantic keys removed or converted.
 8097: #
 8098: # Side effects: None.
 8099: #
 8100: # Notes:      Semantic types are mapped to
 8101: #             appropriate base types with additional
 8102: #             constraint and note fields.
 8103: #             The original $param hashref is not
 8104: #             modified.
 8105: # --------------------------------------------------
 8106: sub _serialize_parameter_for_yaml {
●8107 → 8112 → 8117 8107: 	my ($self, $param) = @_;
 8108: 
 8109: 	my %cleaned;
 8110: 
 8111: 	# Copy basic fields that App::Test::Generator expects
 8112: 	foreach my $field (qw(type position optional min max matches default)) {
 8113: 		$cleaned{$field} = $param->{$field} if defined $param->{$field};
 8114: 	}
 8115: 
 8116: 	# Handle advanced type mappings
●8117 → 8117 → 8171 8117: 	if(my $semantic = $param->{semantic}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8118: 		if ($semantic eq 'datetime_object') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8119: 			# DateTime objects: test generator needs to know how to create them
 8120: 			$cleaned{type} = 'object';
 8121: 			$cleaned{isa} = $param->{isa} || 'DateTime';
 8122: 			$cleaned{_note} = 'Requires DateTime object';
 8123: 		} elsif ($semantic eq 'timepiece_object') {
 8124: 			$cleaned{type} = 'object';
 8125: 			$cleaned{isa} = $param->{isa} || 'Time::Piece';
 8126: 			$cleaned{_note} = 'Requires Time::Piece object';
 8127: 		} elsif ($semantic eq 'date_string') {
 8128: 			# Date strings: provide regex pattern
 8129: 			$cleaned{type} = 'string';
 8130: 			$cleaned{matches} ||= '/^\d{4}-\d{2}-\d{2}$/';
 8131: 			$cleaned{_example} = '2024-12-12';
 8132: 		} elsif ($semantic eq 'iso8601_string') {
 8133: 			$cleaned{type} = 'string';
 8134: 			$cleaned{matches} ||= '/^\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}Z?$/';
 8135: 			$cleaned{_example} = '2024-12-12T10:30:00Z';
 8136: 		} elsif ($semantic eq 'unix_timestamp') {
 8137: 			$cleaned{type} = 'integer';
 8138: 			$cleaned{min} ||= 0;
 8139: 			$cleaned{max} ||= $INT32_MAX;	# 32-bit max
 8140: 			$cleaned{_note} = 'UNIX timestamp';
 8141: 		} elsif ($semantic eq 'datetime_parseable') {
 8142: 			$cleaned{type} = 'string';
 8143: 			$cleaned{_note} = 'Must be parseable as datetime';
 8144: 		} elsif ($semantic eq 'filehandle') {
 8145: 			# File handles: special handling needed
 8146: 			$cleaned{type} = 'object';
 8147: 			$cleaned{isa} = $param->{isa} || 'IO::Handle';
 8148: 			$cleaned{_note} = 'File handle - may need mock in tests';
 8149: 		} elsif ($semantic eq 'filepath') {
 8150: 			# File paths: string with path pattern
 8151: 			$cleaned{type} = 'string';
 8152: 			$cleaned{matches} ||= '/^[\\w\\/.\\-_]+$/';
 8153: 			$cleaned{_note} = 'File path';
 8154: 		} elsif ($semantic eq 'callback') {
 8155: 			# Coderefs: mark as special type
 8156: 			$cleaned{type} = 'coderef';
 8157: 			$cleaned{_note} = 'CODE reference - provide sub { } in tests';
 8158: 		} elsif ($semantic eq 'enum') {
 8159: 			# Enum: keep as string but add valid values
 8160: 			$cleaned{type} = 'string';
 8161: 			if ($param->{enum} && ref($param->{enum}) eq 'ARRAY') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8162: 				$cleaned{enum} = $param->{enum};
 8163: 				$cleaned{_note} = 'Must be one of: ' . join(', ', @{$param->{enum}});
 8164: 			}
 8165: 		}
 8166: 	}
 8167: 
 8168: 	# Handle memberof even if not marked with semantic.
 8169: 	# enum and memberof are mutually exclusive — only set memberof when enum
 8170: 	# is not already being output (avoids the "has both" validation error).
●8171 → 8171 → 8174 8171: 	if($param->{enum} && ref($param->{enum}) eq 'ARRAY' && !$cleaned{enum}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8172: 		$cleaned{memberof} = $param->{enum};
 8173: 	}
●8174 → 8174 → 8179 8174: 	if($param->{memberof} && ref($param->{memberof}) eq 'ARRAY') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8175: 		$cleaned{memberof} = $param->{memberof};
 8176: 	}
 8177: 
 8178: 	# Handle object class
●8179 → 8179 → 8184 8179: 	if ($param->{isa} && !$cleaned{isa}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8180: 		$cleaned{isa} = $param->{isa};
 8181: 	}
 8182: 
 8183: 	# Add format hints where available
●8184 → 8184 → 8189 8184: 	if ($param->{format}) {

					

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

 8185: 		$cleaned{_format} = $param->{format};
 8186: 	}
 8187: 
 8188: 	# Remove internal fields
 8189: 	delete $cleaned{_source};
 8190: 	delete $cleaned{_from_input_spec};
 8191: 	delete $cleaned{semantic};
 8192: 
 8193: 	return \%cleaned;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8194: }
 8195: 
 8196: # --------------------------------------------------
 8197: # _format_relationship
 8198: #
 8199: # Purpose:    Format a relationship hashref as a
 8200: #             short human-readable description
 8201: #             string for use in YAML comments.
 8202: #
 8203: # Entry:      $rel - relationship hashref as
 8204: #                    produced by the relationship
 8205: #                    detection methods.
 8206: #
 8207: # Exit:       Returns a description string.
 8208: #             Returns 'Unknown relationship' for
 8209: #             unrecognised types.
 8210: #
 8211: # Side effects: None.
 8212: # --------------------------------------------------
 8213: sub _format_relationship {
●8214 → 8216 → 8229 8214: 	my $rel = $_[0];
 8215: 
 8216: 	if ($rel->{type} eq 'mutually_exclusive') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8217: 		return 'Mutually exclusive: ' . join(', ', @{$rel->{params}});

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8218: 	} elsif ($rel->{type} eq 'required_group') {
 8219: 		return "Required group (OR): " . join(', ', @{$rel->{params}});

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8220: 	} elsif ($rel->{type} eq 'conditional_requirement') {
 8221: 		return "If $rel->{if} then $rel->{then_required} required";

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8222: 	} elsif ($rel->{type} eq 'dependency') {
 8223: 		return "$rel->{param} depends on $rel->{requires}";

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8224: 	} elsif ($rel->{type} eq 'value_constraint') {
 8225: 		return "If $rel->{if} then $rel->{then} $rel->{operator} $rel->{value}";

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8226: 	} elsif ($rel->{type} eq 'value_conditional') {
 8227: 		return "If $rel->{if}='$rel->{equals}' then $rel->{then_required} required";

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8228: 	}
 8229: 	return 'Unknown relationship';

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8230: }
 8231: 
 8232: # --------------------------------------------------
 8233: # _needs_object_instantiation
 8234: #
 8235: # Purpose:    Determine whether a method requires
 8236: #             an object to be instantiated before
 8237: #             it can be called, and if so return
 8238: #             the package name to instantiate.
 8239: #
 8240: # Entry:      $method_name - name of the method.
 8241: #             $method_body - method source string.
 8242: #             $method_info - method hashref from
 8243: #                            _find_methods (optional,
 8244: #                            for backward compat).
 8245: #
 8246: # Exit:       Returns the package name string if
 8247: #             object instantiation is required.
 8248: #             Returns undef if the method is a
 8249: #             constructor, factory, singleton, or
 8250: #             pure class method.
 8251: #
 8252: # Side effects: Logs analysis decisions to stdout
 8253: #               when verbose is set.
 8254: #
 8255: # Notes:      Orchestrates five detection sub-steps:
 8256: #             factory detection, singleton detection,
 8257: #             instance method detection, inheritance
 8258: #             check, and constructor requirements.
 8259: #             Instance method detection overrides
 8260: #             factory detection when both fire.
 8261: # --------------------------------------------------
 8262: sub _needs_object_instantiation {
●8263 → 8289 → 8293 8263: 	my ($self, $method_name, $method_body, $method_info) = @_;
 8264: 
 8265: 	# Allow method_info to be optional for backward compatibility
 8266: 	$method_info ||= {};
 8267: 
 8268: 	my $doc = $self->{_document};
 8269: 	return undef unless $doc;

					

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

 8270: 
 8271: 	# Get the current package name
 8272: 	my $package_stmt = $doc->find_first('PPI::Statement::Package');
 8273: 	my $current_package = $package_stmt ? $package_stmt->namespace : 'UNKNOWN';
 8274: 	$self->{_package_name} //= $current_package;
 8275: 
 8276: 	# Initialize result structure
 8277: 	my $result = {
 8278: 		package => $current_package,
 8279: 		needs_object => 0,
 8280: 		type => 'unknown',
 8281: 		details => {},
 8282: 		constructor_params => undef,
 8283: 	};
 8284: 
 8285: 	# Track whether we should explicitly skip object instantiation
 8286: 	my $skip_object = 0;
 8287: 
 8288: 	# Skip constructors and destructors
 8289: 	if ($method_name eq 'new') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8290: 		$self->_log("  OBJECT: Constructor '$method_name' detected; skipping instantiation analysis");
 8291: 		return undef;

					

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

 8292: 	}
●8293 → 8293 → 8298 8293: 	if($method_name =~ /^(create|build|construct|init|DESTROY)$/i) {

					

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

 8294: 		$skip_object = 1;
 8295: 	}
 8296: 
 8297: 	# 1. Check for factory methods that return instances
●8298 → 8304 → 8315 8298: 	my $is_factory = $self->_detect_factory_method(
 8299: 		$method_name, $method_body, $current_package, $method_info
 8300: 	);
 8301: 
 8302: 	# 2. Check for singleton patterns
 8303: 	my $is_singleton = $self->_detect_singleton_pattern($method_name, $method_body);
 8304: 	if ($is_singleton) {

					

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

 8305: 		$result->{needs_object} = 0;	# Singleton methods return the singleton instance
 8306: 		$result->{type} = 'singleton_accessor';
 8307: 		$result->{details} = $is_singleton;
 8308: 		$self->_log("  OBJECT: Detected singleton accessor '$method_name'");
 8309: 		# Singleton accessors typically don't need object creation in tests
 8310: 		# as they're called on the class, not instance
 8311: 		$skip_object = 1;
 8312: 	}
 8313: 
 8314: 	# 3. Check if this is an instance method that needs an object
●8315 → 8316 → 8363 8315: 	my $is_instance_method = $self->_detect_instance_method($method_name, $method_body);
 8316: 	if ($is_instance_method &&

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8317: 	    ($is_instance_method->{explicit_self} ||
 8318: 	     $is_instance_method->{shift_self} ||
 8319: 	     $is_instance_method->{accesses_object_data} ||
 8320: 	     ($is_instance_method->{calls_instance_methods} &&
 8321: 	      scalar @{$is_instance_method->{calls_instance_methods}}))) {
 8322: 
 8323: 		# Instance-only methods override factory detection
 8324: 		if ($is_factory) {

					

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

 8325: 			$self->_log(
 8326: 				"  OBJECT: Instance-only method '$method_name' overrides factory detection"
 8327: 			);
 8328: 		}
 8329: 
 8330: 		$result->{needs_object} = 1;
 8331: 		$result->{type} = 'instance_method';
 8332: 		$result->{details} = $is_instance_method;
 8333: 
 8334: 		# 4. Check for inheritance - if parent class constructor should be used
 8335: 		my $inheritance_info = $self->_check_inheritance_for_constructor(
 8336: 			$current_package, $method_body
 8337: 		);
 8338: 		if ($inheritance_info && $inheritance_info->{use_parent_constructor}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8339: 			$result->{package} = $inheritance_info->{parent_class};
 8340: 			$result->{details}{inheritance} = $inheritance_info;
 8341: 			$self->_log(
 8342: 				"  OBJECT: Method '$method_name' uses parent class constructor: $inheritance_info->{parent_class}"
 8343: 			);
 8344: 		}
 8345: 
 8346: 		# 5. Check if constructor needs specific parameters
 8347: 		my $constructor_needs = $self->_detect_constructor_requirements(
 8348: 			$current_package, $result->{package}
 8349: 		);
 8350: 		if ($constructor_needs) {

					

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

 8351: 			$result->{constructor_params} = $constructor_needs;
 8352: 			$result->{details}{constructor_requirements} = $constructor_needs;
 8353: 			$self->_log(
 8354: 				"  OBJECT: Constructor for $result->{package} requires parameters"
 8355: 			);
 8356: 		}
 8357: 
 8358: 		# Return the package name (or parent package) that needs instantiation
 8359: 		return $result->{package};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8360: 	}
 8361: 
 8362: 	# 6. Check for class methods that might need objects from other classes
●8363 → 8364 → 8378 8363: 	my $needs_other_object = $self->_detect_external_object_dependency($method_body);
 8364: 	if ($needs_other_object) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8365: 		$result->{needs_object} = 1;
 8366: 		$result->{type} = 'external_dependency';
 8367: 		$result->{package} = $needs_other_object->{package}
 8368: 			if $needs_other_object->{package};
 8369: 		$result->{details} = $needs_other_object;
 8370: 
 8371: 		$self->_log(
 8372: 			"  OBJECT: Method '$method_name' depends on external object: $needs_other_object->{package}"
 8373: 		);
 8374: 		return $result->{package} if $result->{package};

					

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

 8375: 	}
 8376: 
 8377: 	# Factory method only if NOT instance-based
●8378 → 8378 → 8387 8378: 	if ($is_factory && !$skip_object) {

					

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

 8379: 		$result->{needs_object} = 0;
 8380: 		$result->{type} = 'factory';
 8381: 		$result->{details} = $is_factory;
 8382: 		$self->_log(
 8383: 			"  OBJECT: Detected factory method '$method_name' returns $is_factory->{returns_class} objects"
 8384: 		) if $is_factory->{returns_class};
 8385: 	}
 8386: 
 8387: 	return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8388: }
 8389: 
 8390: # --------------------------------------------------
 8391: # _detect_factory_method
 8392: #
 8393: # Purpose:    Detect whether a method is a factory
 8394: #             that creates and returns object
 8395: #             instances rather than operating on
 8396: #             an existing instance.
 8397: #
 8398: # Entry:      $method_name     - method name string.
 8399: #             $method_body     - method source string.
 8400: #             $current_package - current package name.
 8401: #             $method_info     - method hashref
 8402: #                                (optional).
 8403: #
 8404: # Exit:       Returns a factory_info hashref on
 8405: #             detection, or undef if the method
 8406: #             is not a factory.
 8407: #             The hashref includes: returns_class,
 8408: #             confidence, and one of:
 8409: #             returns_blessed, returns_new,
 8410: #             returns_factory_result, pod_hint.
 8411: #
 8412: # Side effects: None.
 8413: # --------------------------------------------------
 8414: sub _detect_factory_method {
●8415 → 8420 → 8425 8415: 	my ($self, $method_name, $method_body, $current_package, $method_info) = @_;
 8416: 
 8417: 	my %factory_info;
 8418: 
 8419: 	# Check method name patterns
 8420: 	if ($method_name =~ /^(create_|make_|build_|get_)/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8421: 		$factory_info{name_pattern} = 1;
 8422: 	}
 8423: 
 8424: 	# Look for object creation patterns in the method body
●8425 → 8425 → 8476 8425: 	if ($method_body) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8426: 		# Pattern 1: Returns a blessed reference
 8427: 		if ($method_body =~ /return\s+bless\s*\{[^}]*\},\s*['"]?(\w+(?:::\w+)*|\$\w+)['"]?/s ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8428: 			$method_body =~ /bless\s*\{[^}]*\},\s*['"]?(\w+(?:::\w+)*|\$\w+)['"]?.*return/s) {
 8429: 			my $class_name = $1;
 8430: 
 8431: 			# Handle variable class names
 8432: 			if ($class_name =~ /^\$(class|self|package)$/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8433: 				$factory_info{returns_class} = $current_package;
 8434: 			} elsif ($class_name =~ /^\$/) {
 8435: 				$factory_info{returns_class} = 'VARIABLE';	# Unknown variable
 8436: 			} else {
 8437: 				$factory_info{returns_class} = $class_name;
 8438: 			}
 8439: 
 8440: 			$factory_info{returns_blessed} = 1;
 8441: 			$factory_info{confidence} = 'high';
 8442: 			return \%factory_info;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8443: 		}
 8444: 
 8445: 		# Pattern 2: Returns ->new() call on class or $self
 8446: 		if ($method_body =~ /return\s+([\$\w:]+)->new\(/s ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8447: 			$method_body =~ /([\$\w:]+)->new\(.*return/s) {
 8448: 			my $target = $1;
 8449: 
 8450: 			# Determine what class is being instantiated
 8451: 			if ($target eq '$self' || $target eq 'shift' || $target =~ /^\$/) {

					

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

 8452: 				$factory_info{returns_class} = $current_package;
 8453: 				$factory_info{self_new} = 1;
 8454: 			} elsif ($target =~ /::/) {
 8455: 				$factory_info{returns_class} = $target;
 8456: 				$factory_info{external_class} = 1;
 8457: 			} else {
 8458: 				$factory_info{returns_class} = $target;
 8459: 			}
 8460: 
 8461: 			$factory_info{returns_new} = 1;
 8462: 			$factory_info{confidence} = 'medium';
 8463: 			return \%factory_info;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8464: 		}
 8465: 
 8466: 		# Pattern 3: Returns an object from another factory method
 8467: 		if ($method_body =~ /return\s+([\$\w:]+)->(create_|make_|build_|get_)/i ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8468: 			$method_body =~ /([\$\w:]+)->(create_|make_|build_|get_).*return/si) {
 8469: 			$factory_info{returns_factory_result} = 1;
 8470: 			$factory_info{confidence} = 'low';
 8471: 			return \%factory_info;

					

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

 8472: 		}
 8473: 	}
 8474: 
 8475: 	# Check for return type hints in POD if available
●8476 → 8476 → 8485 8476: 	if ($method_info && ref($method_info) eq 'HASH' && $method_info->{pod}) {

					

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

 8477: 		my $pod = $method_info->{pod};
 8478: 		if ($pod =~ /returns?\s+(?:an?\s+)?(object|instance|new\s+\w+)/i) {

					

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

 8479: 			$factory_info{pod_hint} = 1;
 8480: 			$factory_info{confidence} = 'low';
 8481: 			return \%factory_info;

					

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

 8482: 		}
 8483: 	}
 8484: 
 8485: 	return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8486: }
 8487: 
 8488: # --------------------------------------------------
 8489: # _detect_singleton_pattern
 8490: #
 8491: # Purpose:    Detect singleton accessor methods
 8492: #             that return a shared instance rather
 8493: #             than creating a new object, by
 8494: #             checking the method name and body
 8495: #             for singleton patterns.
 8496: #
 8497: # Entry:      $method_name - method name string.
 8498: #             $method_body - method source string.
 8499: #
 8500: # Exit:       Returns a singleton_info hashref on
 8501: #             detection (always contains at least
 8502: #             name_pattern => 1), or undef if the
 8503: #             method name does not match the
 8504: #             singleton accessor pattern.
 8505: #
 8506: # Side effects: None.
 8507: #
 8508: # Notes:      Only fires for methods named
 8509: #             instance, get_instance, singleton,
 8510: #             or shared_instance. Methods not
 8511: #             matching these names always return
 8512: #             undef regardless of body content.
 8513: # --------------------------------------------------
 8514: sub _detect_singleton_pattern {
●8515 → 8525 → 8554 8515: 	my ($self, $method_name, $method_body) = @_;
 8516: 
 8517: 	# Check method name patterns
 8518: 	return undef unless $method_name =~ /^(instance|get_instance|singleton|shared_instance)$/i;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8519: 
 8520: 	my %singleton_info = (
 8521: 		name_pattern => 1,
 8522: 	);
 8523: 
 8524: 	# Look for singleton patterns in code
 8525: 	if ($method_body) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8526: 		# Pattern 1: Static/state variable holding instance
 8527: 		if ($method_body =~ /(?:my\s+)?(?:our\s+)?\$(?:instance|_instance|singleton)\b/s ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8528: 			$method_body =~ /state\s+\$(?:instance|_instance|singleton)\b/s) {
 8529: 			$singleton_info{static_variable} = 1;
 8530: 			$singleton_info{confidence} = 'high';
 8531: 		}
 8532: 
 8533: 		# Pattern 2: Returns $instance if defined (with better regex)
 8534: 		if ($method_body =~ /return\s+\$instance\s+if\s+(?:defined\s+)?\$instance/ ||

					

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

 8535: 			$method_body =~ /unless\s+\$instance.*?=\s*.*?new/) {
 8536: 			$singleton_info{returns_instance} = 1;
 8537: 			$singleton_info{confidence} = 'high';
 8538: 		}
 8539: 
 8540: 		# Pattern 3: ||= new() pattern (with better regex)
 8541: 		if ($method_body =~ /\$instance\s*\|\|=\s*.*?new/ ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8542: 			$method_body =~ /\$instance\s*=\s*.*?new\s+unless\s+(?:defined\s+)?\$instance/) {
 8543: 			$singleton_info{lazy_initialization} = 1;
 8544: 			$singleton_info{confidence} = 'medium';
 8545: 		}
 8546: 
 8547: 		# Pattern 4: Direct return of $instance variable
 8548: 		if ($method_body =~ /return\s+\$instance;/) {

					

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

 8549: 			$singleton_info{returns_instance} = 1;
 8550: 			$singleton_info{confidence} = 'high' unless $singleton_info{confidence};
 8551: 		}
 8552: 	}
 8553: 
 8554: 	return \%singleton_info if keys %singleton_info > 0;	# Need at least name pattern

  Mutants (Total: 5, Killed: 5, Survived: 0)
 8555: 
 8556: 	return undef;

					

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

 8557: }
 8558: 
 8559: # --------------------------------------------------
 8560: # _detect_instance_method
 8561: #
 8562: # Purpose:    Detect whether a method is an
 8563: #             instance method that requires a
 8564: #             blessed object ($self) to be called,
 8565: #             through multiple detection patterns
 8566: #             of varying confidence.
 8567: #
 8568: # Entry:      $method_name - method name string.
 8569: #             $method_body - method source string.
 8570: #
 8571: # Exit:       Returns an instance_info hashref if
 8572: #             any instance method signal is found.
 8573: #             Returns undef if no signals are
 8574: #             detected.
 8575: #             The hashref may contain: explicit_self,
 8576: #             shift_self, uses_self,
 8577: #             accesses_object_data,
 8578: #             calls_instance_methods,
 8579: #             private_method, and confidence.
 8580: #
 8581: # Side effects: None.
 8582: # --------------------------------------------------
 8583: sub _detect_instance_method {
●8584 → 8589 → 8614 8584: 	my ($self, $method_name, $method_body) = @_;
 8585: 
 8586: 	my %instance_info;
 8587: 
 8588: 	# Pattern 1: my ($self, ...) = @_;
 8589: 	if ($method_body =~ /my\s*\(\s*\$self\s*[,)]/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8590: 		$instance_info{explicit_self} = 1;
 8591: 		$instance_info{confidence} = 'high';
 8592: 	}
 8593: 
 8594: 	# Pattern 1b: my $self = $_[0];  (direct-index style)
 8595: 	elsif ($method_body =~ /my\s+\$self\s*=\s*\$_\[0\]/) {
 8596: 		$instance_info{explicit_self} = 1;
 8597: 		$instance_info{confidence} = 'high';
 8598: 	}
 8599: 
 8600: 	# Pattern 2: my $self = shift;
 8601: 	elsif ($method_body =~ /my\s+\$self\s*=\s*shift/) {
 8602: 		$instance_info{shift_self} = 1;
 8603: 		$instance_info{confidence} = 'high';
 8604: 	}
 8605: 
 8606: 	# Pattern 3: Uses $self->something (including hash/array access)
 8607: 	# This catches $self->{value} and $self->[0] as well as $self->method()
 8608: 	elsif ($method_body =~ /\$self\s*->\s*(\w+|[\{\[])/) {
 8609: 		$instance_info{uses_self} = 1;
 8610: 		$instance_info{confidence} = 'medium';
 8611: 	}
 8612: 
 8613: 	# Pattern 4: Accesses object data: $self->{...}, $self->[...]
●8614 → 8614 → 8620 8614: 	if ($method_body =~ /\$self\s*->\s*[\{\[]/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8615: 		$instance_info{accesses_object_data} = 1;
 8616: 		$instance_info{confidence} = 'high' unless $instance_info{confidence} eq 'high';
 8617: 	}
 8618: 
 8619: 	# Pattern 5: Calls other instance methods on $self
●8620 → 8620 → 8629 8620: 	if ($method_body =~ /\$self\s*->\s*(\w+)\s*\(/s) {

					

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

 8621: 		$instance_info{calls_instance_methods} = [];
 8622: 		while ($method_body =~ /\$self\s*->\s*(\w+)\s*\(/g) {
 8623: 			push @{$instance_info{calls_instance_methods}}, $1;
 8624: 		}
 8625: 		$instance_info{confidence} = 'high' if @{$instance_info{calls_instance_methods}};
 8626: 	}
 8627: 
 8628: 	# Pattern 6: Method name suggests instance method (not perfect but helpful)
●8629 → 8629 → 8635 8629: 	if ($method_name =~ /^_/ && $method_name !~ /^_new/) {

					

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

 8630: 		# Private methods are usually instance methods
 8631: 		$instance_info{private_method} = 1;
 8632: 		$instance_info{confidence} = 'low' unless exists $instance_info{confidence};
 8633: 	}
 8634: 
 8635: 	return \%instance_info if keys %instance_info;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8636: 	return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8637: }
 8638: 
 8639: # --------------------------------------------------
 8640: # _check_inheritance_for_constructor
 8641: #
 8642: # Purpose:    Determine whether the current package
 8643: #             uses an inherited constructor from a
 8644: #             parent class, by examining use parent,
 8645: #             use base, and @ISA declarations.
 8646: #
 8647: # Entry:      $current_package - current package
 8648: #                                name string.
 8649: #             $method_body     - method source string
 8650: #                                (checked for SUPER::
 8651: #                                calls).
 8652: #
 8653: # Exit:       Returns an inheritance_info hashref
 8654: #             if any inheritance information is
 8655: #             found, or undef otherwise.
 8656: #             The hashref may contain:
 8657: #             parent_statements, isa_array,
 8658: #             uses_super, calls_super_new,
 8659: #             has_own_constructor,
 8660: #             use_parent_constructor, parent_class.
 8661: #
 8662: # Side effects: None.
 8663: # --------------------------------------------------
 8664: sub _check_inheritance_for_constructor {
●8665 → 8677 → 8693 8665: 	my ($self, $current_package, $method_body) = @_;
 8666: 
 8667: 	my $doc = $self->{_document};
 8668: 	return undef unless $doc;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8669: 
 8670: 	my %inheritance_info;
 8671: 
 8672: 	# 1. Look for parent/base statements
 8673: 	my @parent_classes;
 8674: 
 8675: 	# Find all 'use parent' or 'use base' statements
 8676: 	my $includes = $doc->find('PPI::Statement::Include') || [];
 8677: 	foreach my $inc (@$includes) {
 8678: 		my $content = $inc->content;
 8679: 		if ($content =~ /use\s+(parent|base)\s+['"]?([\w:]+)['"]?/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8680: 			push @parent_classes, $2;
 8681: 			$inheritance_info{parent_statements} = \@parent_classes;
 8682: 		}
 8683: 		# Also check for multiple parents: use parent qw(Class1 Class2)
 8684: 		if ($content =~ /use\s+(parent|base)\s+qw?[\(\[]?(.+?)[\)\]]?;/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8685: 			my $parents = $2;
 8686: 			my @multi_parents = split /\s+/, $parents;
 8687: 			push @parent_classes, @multi_parents;
 8688: 			$inheritance_info{parent_statements} = \@parent_classes;
 8689: 		}
 8690: 	}
 8691: 
 8692: 	# 2. Look for @ISA assignments (with or without 'our')
●8693 → 8694 → 8706 8693: 	my $isas = $doc->find('PPI::Statement::Variable') || [];
 8694: 	foreach my $isa (@$isas) {
 8695: 		my $content = $isa->content();
 8696: 		# Match both "our @ISA = qw(...)" and "@ISA = qw(...)"
 8697: 		if ($content =~ /(?:our\s+)?\@ISA\s*=\s*qw?[\(\[]?(.+?)[\)\]]?/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8698: 			my $parents = $1;
 8699: 			my @isa_parents = split(/\s+/, $parents);
 8700: 			push @parent_classes, @isa_parents;
 8701: 			$inheritance_info{isa_array} = \@isa_parents;
 8702: 		}
 8703: 	}
 8704: 
 8705: 	# Also look for @ISA in regular statements
●8706 → 8707 → 8718 8706: 	my $statements = $doc->find('PPI::Statement') || [];
 8707: 	foreach my $stmt (@$statements) {
 8708: 		my $content = $stmt->content;
 8709: 		if ($content =~ /\@ISA\s*=\s*qw?[\(\[]?(.+?)[\)\]]?/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8710: 			my $parents = $1;
 8711: 			my @isa_parents = split(/\s+/, $parents);
 8712: 			push @parent_classes, @isa_parents;
 8713: 			$inheritance_info{isa_array} = \@isa_parents;
 8714: 		}
 8715: 	}
 8716: 
 8717: 	# 3. Check if method uses SUPER:: calls
●8718 → 8718 → 8726 8718: 	if ($method_body && $method_body =~ /SUPER::/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8719: 		$inheritance_info{uses_super} = 1;
 8720: 		if ($method_body =~ /SUPER::new/) {

					

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

 8721: 			$inheritance_info{calls_super_new} = 1;
 8722: 		}
 8723: 	}
 8724: 
 8725: 	# 4. Check if current package has its own new method
●8726 → 8731 → 8739 8726: 	my $has_own_new = $doc->find(sub {
 8727: 		$_[1]->isa('PPI::Statement::Sub') &&
 8728: 		$_[1]->name eq 'new'
 8729: 	});
 8730: 
 8731: 	if ($has_own_new) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8732: 		$inheritance_info{has_own_constructor} = 1;
 8733: 	} elsif (@parent_classes) {
 8734: 		# No own constructor, but has parents - might need parent constructor
 8735: 		$inheritance_info{use_parent_constructor} = 1;
 8736: 		$inheritance_info{parent_class} = $parent_classes[0];	# Use first parent
 8737: 	}
 8738: 
 8739: 	return \%inheritance_info if keys %inheritance_info;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8740: 	return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8741: }
 8742: 
 8743: # --------------------------------------------------
 8744: # _detect_constructor_requirements
 8745: #
 8746: # Purpose:    Analyse the new() method of the
 8747: #             current or target package to determine
 8748: #             what parameters the constructor
 8749: #             requires, including required and
 8750: #             optional parameters and their defaults.
 8751: #
 8752: # Entry:      $current_package - the package being
 8753: #                                analysed.
 8754: #             $target_package  - the package whose
 8755: #                                constructor will
 8756: #                                be called (may
 8757: #                                differ from current
 8758: #                                for inherited
 8759: #                                constructors).
 8760: #
 8761: # Exit:       Returns a requirements hashref on
 8762: #             success, or undef if no new() method
 8763: #             is found. For external classes,
 8764: #             returns a minimal hashref with
 8765: #             external_class => 1.
 8766: #
 8767: # Side effects: None.
 8768: # --------------------------------------------------
 8769: sub _detect_constructor_requirements {
●8770 → 8777 → 8786 8770: 	my ($self, $current_package, $target_package) = @_;
 8771: 
 8772: 	my $doc = $self->{_document};
 8773: 	return undef unless $doc;

					

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

 8774: 
 8775: 	# If target is different from current, we can't analyze it
 8776: 	# (external class, parent class in different file)
 8777: 	if ($target_package ne $current_package) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8778: 		return {
 8779: 			external_class => 1,
 8780: 			package => $target_package,
 8781: 			note => "Constructor for external class $target_package - parameters unknown"
 8782: 		};
 8783: 	}
 8784: 
 8785: 	# Find the new method in current package
●8786 → 8799 → 8810 8786: 	my $new_method = $doc->find_first(sub {
 8787: 		$_[1]->isa('PPI::Statement::Sub') &&
 8788: 		$_[1]->name eq 'new'
 8789: 	});
 8790: 
 8791: 	return undef unless $new_method;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8792: 
 8793: 	my %requirements;
 8794: 
 8795: 	# Get method body
 8796: 	my $body = $new_method->content;
 8797: 
 8798: 	# Look for parameter extraction patterns - handle both $self and $class
 8799: 	if ($body =~ /my\s*\(\s*\$(self|class)\s*,\s*(.+?)\)\s*=\s*\@_/s) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8800: 		my $params = $2;
 8801: 		my @param_names = $params =~ /\$(\w+)/g;
 8802: 
 8803: 		if (@param_names) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8804: 			$requirements{parameters} = \@param_names;
 8805: 			$requirements{parameter_count} = scalar @param_names;
 8806: 		}
 8807: 	}
 8808: 
 8809: 	# Look for shift patterns
●8810 → 8811 → 8815 8810: 	my @shift_params;
 8811: 	while ($body =~ /my\s+\$(\w+)\s*=\s*shift/g) {
 8812: 		push @shift_params, $1;
 8813: 	}
 8814: 	# Remove $self or $class if present
●8815 → 8817 → 8824 8815: 	@shift_params = grep { $_ !~ /^(self|class)$/i } @shift_params;
 8816: 
 8817: 	if (@shift_params) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8818: 		$requirements{parameters} = \@shift_params;
 8819: 		$requirements{parameter_count} = scalar @shift_params;
 8820: 		$requirements{shift_pattern} = 1;
 8821: 	}
 8822: 
 8823: 	# Look for validation of parameters (more flexible pattern)
●8824 → 8825 → 8828 8824: 	my @required_params;
 8825: 	if ($body =~ /croak.*unless.*(?:defined\s+)?\$(\w+)/g) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8826: 		push @required_params, $1;
 8827: 	}
●8828 → 8828 → 8832 8828: 	if ($body =~ /die.*unless.*(?:defined\s+)?\$(\w+)/g) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8829: 		push @required_params, $1;
 8830: 	}
 8831: 
●8832 → 8832 → 8837 8832: 	if (@required_params) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8833: 		$requirements{required_parameters} = \@required_params;
 8834: 	}
 8835: 
 8836: 	# Look for default values (optional parameters)
●8837 → 8842 → 8852 8837: 	my @optional_params;
 8838: 	my %default_values;
 8839: 
 8840: 	# Use the new _extract_default_value method
 8841: 	# Check for each parameter in the constructor body
 8842: 	if ($requirements{parameters}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8843: 		foreach my $param (@{$requirements{parameters}}) {
 8844: 			my $default = $self->_extract_default_value($param, $body);
 8845: 			if (defined $default) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8846: 				push @optional_params, $param;
 8847: 				$default_values{$param} = $default;
 8848: 			}
 8849: 		}
 8850: 	}
 8851: 
●8852 → 8852 → 8857 8852: 	if (@optional_params) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8853: 		$requirements{optional_parameters} = \@optional_params;
 8854: 		$requirements{default_values} = \%default_values;
 8855: 	}
 8856: 
 8857: 	return \%requirements if keys %requirements;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8858: 	return undef;

					

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

 8859: }
 8860: 
 8861: 
 8862: # --------------------------------------------------
 8863: # _detect_external_object_dependency
 8864: #
 8865: # Purpose:    Detect whether a method creates or
 8866: #             depends on objects from classes other
 8867: #             than the current package, by scanning
 8868: #             for ->new() calls on named classes
 8869: #             and method calls on typed variables.
 8870: #
 8871: # Entry:      $method_body - method source string.
 8872: #                            May be undef.
 8873: #
 8874: # Exit:       Returns a dependency_info hashref if
 8875: #             external object usage is found, or
 8876: #             undef otherwise.
 8877: #             The hashref may contain:
 8878: #             creates_objects (arrayref of class
 8879: #             names), uses_objects (arrayref of
 8880: #             class names), and package (the primary
 8881: #             dependency class).
 8882: #
 8883: # Side effects: None.
 8884: # --------------------------------------------------
 8885: sub _detect_external_object_dependency {
●8886 → 8895 → 8901 8886: 	my ($self, $method_body) = @_;
 8887: 
 8888: 	return undef unless $method_body;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8889: 
 8890: 	my %dependency_info;
 8891: 
 8892: 	# Pattern 1: Creates objects of other classes with ->new() or ->create()
 8893: 	# Reset pos for global match
 8894: 	pos($method_body) = 0;
 8895: 	while ($method_body =~ /(\w+(?:::\w+)*)->(?:new|create)\(/g) {
 8896: 		my $class = $1;
 8897: 		next if $class eq 'main' || $class eq '__PACKAGE__' || $class =~ /^\$/;
 8898: 		push @{$dependency_info{creates_objects}}, $class;
 8899: 	}
 8900: 
●8901 → 8901 → 8909 8901: 	if ($dependency_info{creates_objects}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8902: 		# Remove duplicates
 8903: 		my %seen;
 8904: 		$dependency_info{creates_objects} = [grep { !$seen{$_}++ } @{$dependency_info{creates_objects}}];
 8905: 		$dependency_info{package} = $dependency_info{creates_objects}[0];
 8906: 	}
 8907: 
 8908: 	# Pattern 2: Calls methods on objects from other classes
●8909 → 8909 → 8939 8909: 	if ($method_body =~ /\$(\w+)->\w+\(/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8910: 		my %object_vars;
 8911: 		# Reset pos for global match — the if check above used a
 8912: 		# non-/g match so it cannot have advanced pos, but the while
 8913: 		# loop's own /g matches still need to start from the beginning.
 8914: 		pos($method_body) = 0;
 8915: 		while ($method_body =~ /\$(\w+)->\w+\(/g) {
 8916: 			$object_vars{$1}++;
 8917: 		}
 8918: 
 8919: 		# Try to determine type of object variables
 8920: 		my @object_classes;
 8921: 		foreach my $var (keys %object_vars) {
 8922: 			# Look for type declarations or assignments
 8923: 			if ($method_body =~ /my\s+\$$var\s*=\s*(\w+(?:::\w+)+)->(?:new|create)/) {

					

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

 8924: 				push @object_classes, $1;
 8925: 			} elsif ($method_body =~ /my\s+\$$var\s*=\s*(\w+(?:::\w+)+)->/) {
 8926: 				push @object_classes, $1;
 8927: 			}
 8928: 		}
 8929: 
 8930: 		if (@object_classes) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 8931: 			$dependency_info{uses_objects} = \@object_classes;
 8932: 			$dependency_info{package} = $object_classes[0] unless $dependency_info{package};
 8933: 		}
 8934: 	}
 8935: 
 8936: 	# Pattern 3: Receives objects as parameters (type hints in comments/POD)
 8937: 	# This would need integration with parameter analysis
 8938: 
 8939: 	return \%dependency_info if keys %dependency_info;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8940: 	return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 8941: }
 8942: 
 8943: # --------------------------------------------------
 8944: # _get_parent_class
 8945: #
 8946: # Purpose:    Find the first parent class of the
 8947: #             current package by searching the
 8948: #             PPI document for use parent, use base,
 8949: #             or our @ISA declarations.
 8950: #
 8951: # Entry:      None (operates on $self->{_document}).
 8952: #
 8953: # Exit:       Returns the parent class name string,
 8954: #             or undef if no parent is found.
 8955: #
 8956: # Side effects: None.
 8957: # --------------------------------------------------
 8958: sub _get_parent_class {
●8959 → 8971 → 8977 8959: 	my $self = $_[0];
 8960: 
 8961: 	my $doc = $self->{_document};
 8962: 	return unless $doc;
 8963: 
 8964: 	# Look for use parent statements
 8965: 	my $parent_stmt = $doc->find_first(sub {
 8966: 		$_[1]->isa('PPI::Statement::Include') &&
 8967: 		$_[1]->type eq 'use' &&
 8968: 		$_[1]->module =~ /^(parent|base)$/ &&
 8969: 		$_[1]->arguments =~ /['"](\w+(?:::\w+)*)['"]/
 8970: 	});
 8971: 	if ($parent_stmt) {

					

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

 8972: 		my $parent = $1;
 8973: 		return $parent;

					

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

 8974: 	}
 8975: 
 8976: 	# Look for @ISA assignment
●8977 → 8981 → 8985 8977: 	my $isa_stmt = $doc->find_first(sub {
 8978: 		$_[1]->isa('PPI::Statement') &&
 8979: 		$_[1]->content =~ /our\s+\@ISA\s*=\s*\(\s*['"](\w+(?:::\w+)*)['"]\s*\)/
 8980: 	});
 8981: 	if ($isa_stmt && $isa_stmt->content =~ /['"](\w+(?:::\w+)*)['"]/) {

					

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

 8982: 		return $1;

					

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

 8983: 	}
 8984: 
 8985: 	return;
 8986: }
 8987: 
 8988: # --------------------------------------------------
 8989: # _get_class_for_instance_method
 8990: #
 8991: # Purpose:    Determine which class should be used
 8992: #             for object instantiation when testing
 8993: #             an instance method, preferring the
 8994: #             current package if it has a new()
 8995: #             method, falling back to the parent
 8996: #             class otherwise.
 8997: #
 8998: # Entry:      None (operates on $self->{_document}).
 8999: #
 9000: # Exit:       Returns the package name string to
 9001: #             use for instantiation. Returns
 9002: #             'UNKNOWN_PACKAGE' if no package
 9003: #             statement is found.
 9004: #
 9005: # Side effects: Stores the package name in
 9006: #               $self->{_package_name} if not
 9007: #               already set.
 9008: # --------------------------------------------------
 9009: sub _get_class_for_instance_method {
●9010 → 9024 → 9029 9010: 	my $self = $_[0];
 9011: 
 9012: 	# Get the current package
 9013: 	my $doc = $self->{_document};
 9014: 	my $package_stmt = $doc->find_first('PPI::Statement::Package');
 9015: 	return 'UNKNOWN_PACKAGE' unless $package_stmt;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9016: 	my $package_name = $package_stmt->namespace;
 9017: 	$self->{_package_name} //= $package_name;
 9018: 
 9019: 	# Check if the current package has a 'new' method
 9020: 	my $has_new = $doc->find(sub {
 9021: 		$_[1]->isa('PPI::Statement::Sub') && $_[1]->name eq 'new'
 9022: 	});
 9023: 
 9024: 	if ($has_new) {

					

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

 9025: 		return $package_name;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9026: 	}
 9027: 
 9028: 	# Otherwise, try to get the parent class
 9029: 	my $parent = $self->_get_parent_class();
 9030: 	return $parent if $parent;

					

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

 9031: 
 9032: 	# Fallback to current package
 9033: 	return $package_name;

					

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

 9034: }
 9035: 
 9036: # --------------------------------------------------
 9037: # _extract_default_value
 9038: #
 9039: # Purpose:    Extract a default value for a named
 9040: #             parameter from a method body by
 9041: #             matching multiple common Perl default
 9042: #             assignment idioms.
 9043: #
 9044: # Entry:      $param - parameter name string.
 9045: #             $code  - method body source string.
 9046: #
 9047: # Exit:       Returns the cleaned default value
 9048: #             scalar on success, or undef if no
 9049: #             default assignment pattern is found.
 9050: #
 9051: # Side effects: None.
 9052: #
 9053: # Notes:      Eight patterns are tried in order:
 9054: #             ||, //=, defined ternary, unless
 9055: #             defined, ||=, //, multi-line if
 9056: #             !defined, unless defined block.
 9057: #             Comment lines are stripped from the
 9058: #             code before matching to avoid false
 9059: #             positives. Delegates to
 9060: #             _clean_default_value for value
 9061: #             normalisation.
 9062: # --------------------------------------------------
 9063: sub _extract_default_value {
●9064 → 9076 → 9084 9064: 	my ($self, $param, $code) = @_;
 9065: 
 9066: 	return undef unless $param && $code;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9067: 
 9068: 	# Clean up the code for easier pattern matching
 9069: 	# Remove comments to avoid false positives
 9070: 	my $clean_code = $code;
 9071: 	$clean_code =~ s/#.*$//gm;
 9072: 	$clean_code =~ s/^\s+|\s+$//g;
 9073: 
 9074: 	# Pattern 1: $param = $param || 'default_value'
 9075: 	# Also handles: $param = $arg || 'default'
 9076: 	if ($clean_code =~ /\$$param\s*=\s*(?:\$$param|\$[a-zA-Z_]\w*)\s*\|\|\s*([^;]+)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9077: 		my $default = $1;
 9078: 		$default =~ s/\s*;\s*$//;
 9079: 		$default = $self->_clean_default_value($default);
 9080: 		return $default if defined $default;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9081: 	}
 9082: 
 9083: 	# Pattern 2: $param //= 'default_value'
●9084 → 9084 → 9093 9084: 	if ($clean_code =~ /\$$param\s*\/\/=\s*([^;]+)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9085: 		my $default = $1;
 9086: 		$default =~ s/\s*;\s*$//;
 9087: 		$default = $self->_clean_default_value($default);
 9088: 		return $default if defined $default;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9089: 	}
 9090: 
 9091: 	# Pattern 3: $param = defined $param ? $param : 'default'
 9092: 	# Also handles: $param = defined $arg ? $arg : 'default'
●9093 → 9093 → 9101 9093: 	if ($clean_code =~ /\$$param\s*=\s*defined\s+(?:\$$param|\$[a-zA-Z_]\w*)\s*\?\s*(?:\$$param|\$[a-zA-Z_]\w*)\s*:\s*([^;]+)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9094: 		my $default = $1;
 9095: 		$default =~ s/\s*;\s*$//;
 9096: 		$default = $self->_clean_default_value($default);
 9097: 		return $default if defined $default;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9098: 	}
 9099: 
 9100: 	# Pattern 4: $param = 'default' unless defined $param;
●9101 → 9101 → 9108 9101: 	if ($clean_code =~ /\$$param\s*=\s*([^;]+?)\s+unless\s+defined\s+(?:\$$param|\$[a-zA-Z_]\w*)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9102: 		my $default = $1;
 9103: 		$default = $self->_clean_default_value($default);
 9104: 		return $default if defined $default;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9105: 	}
 9106: 
 9107: 	# Pattern 5: $param ||= 'default'
●9108 → 9108 → 9116 9108: 	if ($clean_code =~ /\$$param\s*\|\|=\s*([^;]+)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9109: 		my $default = $1;
 9110: 		$default =~ s/\s*;\s*$//;
 9111: 		$default = $self->_clean_default_value($default);
 9112: 		return $default if defined $default;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9113: 	}
 9114: 
 9115: 	# Pattern 6: $param = $arg // 'default'
●9116 → 9116 → 9124 9116: 	if ($clean_code =~ /\$$param\s*=\s*(?:\$$param|\$[a-zA-Z_]\w*)\s*\/\/\s*([^;]+)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9117: 		my $default = $1;
 9118: 		$default =~ s/\s*;\s*$//;
 9119: 		$default = $self->_clean_default_value($default);
 9120: 		return $default if defined $default;

					

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

 9121: 	}
 9122: 
 9123: 	# Pattern 7: Multi-line: if (!defined $param) { $param = 'default'; }
●9124 → 9124 → 9132 9124: 	if ($clean_code =~ /if\s*\(\s*!defined\s+\$$param\s*\)\s*\{[^}]*\$$param\s*=\s*([^;]+)/s) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9125: 		my $default = $1;
 9126: 		$default =~ s/\s*;\s*$//;
 9127: 		$default = $self->_clean_default_value($default);
 9128: 		return $default if defined $default;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9129: 	}
 9130: 
 9131: 	# Pattern 8: unless (defined $param) { $param = 'default'; }
●9132 → 9132 → 9139 9132: 	if ($clean_code =~ /unless\s*\(\s*defined\s+\$$param\s*\)\s*\{[^}]*\$$param\s*=\s*([^;]+)/s) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9133: 		my $default = $1;
 9134: 		$default =~ s/\s*;\s*$//;
 9135: 		$default = $self->_clean_default_value($default);
 9136: 		return $default if defined $default;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9137: 	}
 9138: 
 9139: 	return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9140: }
 9141: 
 9142: # --------------------------------------------------
 9143: # _extract_test_hints
 9144: #
 9145: # Purpose:    Extract structured test hints from
 9146: #             a method's code and schema, including
 9147: #             boundary values, invalid inputs, and
 9148: #             valid input examples from POD.
 9149: #
 9150: # Entry:      $method - method hashref.
 9151: #             $schema - schema hashref as built so
 9152: #                       far by _analyze_method.
 9153: #
 9154: # Exit:       Returns a hints hashref with keys:
 9155: #             boundary_values, invalid_inputs,
 9156: #             equivalence_classes, valid_inputs.
 9157: #             Keys with empty arrays are deleted
 9158: #             before returning.
 9159: #
 9160: # Side effects: None.
 9161: # --------------------------------------------------
 9162: sub _extract_test_hints {
●9163 → 9179 → 9183 9163: 	my ($self, $method, $schema) = @_;
 9164: 
 9165: 	my %hints = (
 9166: 		boundary_values => [],
 9167: 		invalid_inputs => [],
 9168: 		equivalence_classes => [],
 9169: 		valid_inputs => [],
 9170: 	);
 9171: 
 9172: 	my $code = $method->{body};
 9173: 	return {} unless $code;
 9174: 
 9175: 	$self->_extract_invalid_input_hints($code, \%hints);
 9176: 	$self->_extract_boundary_value_hints($code, \%hints);
 9177: 
 9178: 	# prune empties
 9179: 	for my $k (keys %hints) {
 9180: 		delete $hints{$k} unless @{$hints{$k}};
 9181: 	}
 9182: 
 9183: 	return \%hints;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9184: }
 9185: 
 9186: # --------------------------------------------------
 9187: # _extract_invalid_input_hints
 9188: #
 9189: # Purpose:    Detect likely invalid input values
 9190: #             from a method body by looking for
 9191: #             defined checks, empty string checks,
 9192: #             and negative number checks.
 9193: #
 9194: # Entry:      $code  - method body source string.
 9195: #             $hints - hints hashref (modified in
 9196: #                      place via invalid_inputs key).
 9197: #
 9198: # Exit:       Returns nothing. Appends to
 9199: #             $hints->{invalid_inputs}.
 9200: #
 9201: # Side effects: None.
 9202: # --------------------------------------------------
 9203: sub _extract_invalid_input_hints {
●9204 → 9207 → 9212 9204: 	my ($self, $code, $hints) = @_;
 9205: 
 9206: 	# undef invalid
 9207: 	if ($code =~ /defined\s*\(\s*\$/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9208: 		push @{ $hints->{invalid_inputs} }, 'undef';
 9209: 	}
 9210: 
 9211: 	# empty string invalid
●9212 → 9212 → 9217 9212: 	if ($code =~ /\beq\s*''/ || $code =~ /\blength\s*\(/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9213: 		push @{ $hints->{invalid_inputs} }, '';
 9214: 	}
 9215: 
 9216: 	# negative number invalid
●9217 → 9217 → 0 9217: 	if ($code =~ /\$\w+\s*<\s*0/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9218: 		push @{ $hints->{invalid_inputs} }, -1;
 9219: 	}
 9220: }
 9221: 
 9222: # --------------------------------------------------
 9223: # _extract_boundary_value_hints
 9224: #
 9225: # Purpose:    Extract numeric boundary values from
 9226: #             comparison operators in a method body,
 9227: #             adding both the boundary value and
 9228: #             the value one step either side.
 9229: #
 9230: # Entry:      $code  - method body source string.
 9231: #             $hints - hints hashref (modified in
 9232: #                      place via boundary_values key).
 9233: #
 9234: # Exit:       Returns nothing. Appends to and
 9235: #             deduplicates $hints->{boundary_values}.
 9236: #
 9237: # Side effects: None.
 9238: # --------------------------------------------------
 9239: sub _extract_boundary_value_hints {
●9240 → 9242 → 9257 9240: 	my ($self, $code, $hints) = @_;
 9241: 
 9242: 	while ($code =~ /\$\w+\s*(<=|<|>=|>)\s*(\d+)/g) {
 9243: 		my ($op, $n) = ($1, $2);
 9244: 
 9245: 		if ($op eq '<') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9246: 			push @{ $hints->{boundary_values} }, $n, $n+1;
 9247: 		} elsif ($op eq '<=') {
 9248: 			push @{ $hints->{boundary_values} }, $n, $n+1;
 9249: 		} elsif ($op eq '>') {
 9250: 			push @{ $hints->{boundary_values} }, $n, $n-1;
 9251: 		} elsif ($op eq '>=') {
 9252: 			push @{ $hints->{boundary_values} }, $n, $n-1;
 9253: 		}
 9254: 	}
 9255: 
 9256: 	# Remove duplicates
 9257: 	my %seen;
 9258: 	$hints->{boundary_values} = [ grep { !$seen{$_}++ } @{ $hints->{boundary_values} } ];
 9259: }
 9260: 
 9261: # --------------------------------------------------
 9262: # _extract_pod_examples
 9263: #
 9264: # Purpose:    Extract example method call patterns
 9265: #             from a method's SYNOPSIS POD section
 9266: #             and add them as valid_inputs hints.
 9267: #
 9268: # Entry:      $pod   - POD string for the method.
 9269: #                      May be undef.
 9270: #             $hints - hints hashref (modified in
 9271: #                      place via valid_inputs key).
 9272: #
 9273: # Exit:       Returns $hints. Appends to
 9274: #             $hints->{valid_inputs}.
 9275: #
 9276: # Side effects: Logs the number of examples found
 9277: #               to stdout when verbose is set.
 9278: # --------------------------------------------------
 9279: sub _extract_pod_examples {
●9280 → 9291 → 9309 9280: 	my ($self, $pod, $hints) = @_;
 9281: 
 9282: 	return $hints unless $pod;

					

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

 9283: 
 9284: 	my @examples;
 9285: 
 9286: 	# Extract SYNOPSIS
 9287: 	return $hints unless $pod =~ /=head2\s+SYNOPSIS\s*(.+?)(?=\n=head|\z)/s;

					

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

 9288: 	my $synopsis = $1;
 9289: 
 9290: 	# Constructor examples: ->wilma(foo => 'bar', count => 5)
 9291: 	while ($synopsis =~ /->([a-z_0-9A-Z]+)\s*\(\s*(.*?)\s*\)/sg) {
 9292: 		my ($method, $args) = ($1, $2);
 9293: 		my %kv;
 9294: 
 9295: 		while ($args =~ /(\w+)\s*=>\s*(?:'([^']*)'|"([^"]*)"|(\d+))/g) {
 9296: 			my $key = $1;
 9297: 			my $val = defined $2 ? $2 : defined $3 ? $3 : $4;
 9298: 			$kv{$key} = $val;
 9299: 		}
 9300: 
 9301: 		push @examples, {
 9302: 			style => 'named',
 9303: 			source => 'pod',
 9304: 			args => \%kv,
 9305: 			function => $method,	# TODO: add a sanity check this is what we expect
 9306: 		} if %kv;
 9307: 	}
 9308: 
●9309 → 9309 → 9329 9309: 	unless(scalar(@examples)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9310: 		# Positional calls: func($a, $b)
 9311: 		while ($synopsis =~ /\b(\w+)\s*\(\s*(.*?)\s*\)/sg) {
 9312: 			my ($func, $argstr) = ($1, $2);
 9313: 
 9314: 			# next if $func eq 'new';	# already handled
 9315: 
 9316: 			my @args = map { s/^\s+|\s+$//gr } split /\s*,\s*/, $argstr;
 9317: 
 9318: 			next unless @args;
 9319: 
 9320: 			push @examples, {
 9321: 				style	=> 'positional',
 9322: 				source	=> 'pod',
 9323: 				function => $func,
 9324: 				args	=> \@args,
 9325: 			};
 9326: 		}
 9327: 	}
 9328: 
●9329 → 9329 → 9336 9329: 	if (scalar(@examples)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9330: 		$hints->{valid_inputs} ||= [];
 9331: 		push @{ $hints->{valid_inputs} }, @examples;
 9332: 
 9333: 		$self->_log("  POD: extracted " . scalar(@examples) . " example call(s)");
 9334: 	}
 9335: 
●9336 → 9336 → 9340 9336: 	for my $k (qw(boundary_values invalid_inputs valid_inputs equivalence_classes)) {
 9337: 		$hints->{$k} //= [];
 9338: 	}
 9339: 
 9340: 	return $hints;

					

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

 9341: }
 9342: 
 9343: # --------------------------------------------------
 9344: # _clean_default_value
 9345: #
 9346: # Purpose:    Normalise a raw default value string
 9347: #             extracted from code or POD into a
 9348: #             clean Perl scalar, handling quoted
 9349: #             strings, numeric literals, boolean
 9350: #             keywords, empty containers, and
 9351: #             undef.
 9352: #
 9353: # Entry:      $value     - raw value string.
 9354: #                          May be undef.
 9355: #             $from_code - true if the value was
 9356: #                          extracted from source
 9357: #                          code (affects escape
 9358: #                          sequence handling).
 9359: #
 9360: # Exit:       Returns the cleaned value:
 9361: #               undef   for undef or unparseable
 9362: #               {}      for empty hashrefs
 9363: #               []      for empty arrayrefs
 9364: #               integer for whole numbers
 9365: #               float   for decimal numbers
 9366: #               1 or 0  for boolean keywords
 9367: #               string  for everything else
 9368: #
 9369: # Side effects: None.
 9370: # --------------------------------------------------
 9371: sub _clean_default_value {
●9372 → 9384 → 9391 9372: 	my ($self, $value, $from_code) = @_;
 9373: 
 9374: 	return unless defined $value;
 9375: 
 9376: 	# Remove leading/trailing whitespace
 9377: 	$value =~ s/^\s+|\s+$//g;
 9378: 
 9379: 	# Remove parenthetical notes like "(no password)" only if there's content before them
 9380: 	$value =~ s/(\S+)\s*\([^)]+\)\s*$/$1/;
 9381: 	$value =~ s/^\s+|\s+$//g;
 9382: 
 9383: 	# Handle chained || or // operators - extract the rightmost value
 9384: 	if ($value =~ /\|\||\/{2}/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9385: 		my @parts = split(/\s*(?:\|\||\/{2})\s*/, $value);
 9386: 		$value = $parts[-1];
 9387: 		$value =~ s/^\s+|\s+$//g;
 9388: 	}
 9389: 
 9390: 	# Remove trailing semicolon if present
●9391 → 9394 → 9403 9391: 	$value =~ s/;\s*$//;
 9392: 
 9393: 	# Handle q{}, qq{}, qw{} quotes
 9394: 	if ($value =~ /^qq?\{(.*?)\}$/s) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9395: 		$value = $1;
 9396: 	} elsif ($value =~ /^qw\{(.*?)\}$/s) {
 9397: 		$value = $1;
 9398: 	} elsif ($value =~ /^q[qwx]?\s*([^a-zA-Z0-9\{\[])(.*?)\1$/s) {
 9399: 		$value = $2;
 9400: 	}
 9401: 
 9402: 	# Handle quoted strings
●9403 → 9403 → 9426 9403: 	if ($value =~ /^(['"])(.*)\1$/s) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9404: 		$value = $2;
 9405: 
 9406: 		if ($from_code) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9407: 			# In regex captures from source code, escape sequences are doubled
 9408: 			# \\n in capture needs to become \n for the test
 9409: 			$value =~ s/\\\\/\\/g;
 9410: 		}
 9411: 
 9412: 		# Only unescape the quote characters themselves
 9413: 		$value =~ s/\\"/"/g;
 9414: 		$value =~ s/\\'/'/g;
 9415: 
 9416: 		# If NOT from code (i.e., from POD), interpret escape sequences
 9417: 		unless ($from_code) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9418: 			$value =~ s/\\n/\n/g;
 9419: 			$value =~ s/\\r/\r/g;
 9420: 			$value =~ s/\\t/\t/g;
 9421: 			$value =~ s/\\\\/\\/g;
 9422: 		}
 9423: 	}
 9424: 
 9425: 	# Sometimes trailing ) is left on
●9426 → 9426 → 9431 9426: 	if($value !~ /^\(/) {

					

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

 9427: 		$value =~ s/\)$//;
 9428: 	}
 9429: 
 9430: 	# Handle Perl empty hash (must be before numeric/boolean checks)
●9431 → 9431 → 9436 9431: 	if ($value =~ /^\{\s*\}$/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9432: 		return {};
 9433: 	}
 9434: 
 9435: 	# Handle Perl empty list/array
●9436 → 9436 → 9441 9436: 	if ($value =~ /^\[\s*\]$/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9437: 		return [];
 9438: 	}
 9439: 
 9440: 	# Handle numeric values
●9441 → 9441 → 9450 9441: 	if ($value =~ /^-?\d+(?:\.\d+)?$/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9442: 		if ($value =~ /\./) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9443: 			return $value + 0;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9444: 		} else {
 9445: 			return int($value);

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9446: 		}
 9447: 	}
 9448: 
 9449: 	# Handle boolean keywords
●9450 → 9450 → 9455 9450: 	if ($value =~ /^(true|false)$/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9451: 		return lc($1) eq 'true' ? 1 : 0;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9452: 	}
 9453: 
 9454: 	# Handle Perl boolean constants
●9455 → 9455 → 9462 9455: 	if ($value eq '1') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9456: 		return 1;

					

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

 9457: 	} elsif ($value eq '0') {
 9458: 		return 0;

					

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

 9459: 	}
 9460: 
 9461: 	# Handle undef
●9462 → 9462 → 9467 9462: 	if ($value eq 'undef') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9463: 		return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9464: 	}
 9465: 
 9466: 	# Handle __PACKAGE__ and similar constants
●9467 → 9467 → 9472 9467: 	if ($value eq '__PACKAGE__') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9468: 		return '__PACKAGE__';

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9469: 	}
 9470: 
 9471: 	# Remove surrounding parentheses
●9472 → 9475 → 9480 9472: 	$value =~ s/^\((.+)\)$/$1/;
 9473: 
 9474: 	# Handle expressions we can't evaluate
 9475: 	if ($value =~ /^\$[a-zA-Z_]/ || $value =~ /\(.*\)/) {

					

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

 9476: 		return if($value =~ /^\$|\@|\%/);	# The default is a value, so who knows its type?
 9477: 		# return $value;
 9478: 	}
 9479: 
 9480: 	return $value;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9481: }
 9482: 
 9483: # --------------------------------------------------
 9484: # _validate_pod_code_agreement
 9485: #
 9486: # Purpose:    Compare POD parameter documentation
 9487: #             against code-inferred parameters and
 9488: #             return a list of disagreements when
 9489: #             strict_pod mode is enabled.
 9490: #
 9491: # Entry:      $pod_params  - hashref of parameters
 9492: #                            from POD analysis.
 9493: #             $code_params - hashref of parameters
 9494: #                            from code analysis.
 9495: #             $method_name - method name string,
 9496: #                            used for context in
 9497: #                            error messages.
 9498: #
 9499: # Exit:       Returns a list of disagreement
 9500: #             strings. Returns an empty list if
 9501: #             all parameters agree.
 9502: #
 9503: # Side effects: None.
 9504: #
 9505: # Notes:      Type mismatches are classified as
 9506: #             either 'compatible' (e.g. integer vs
 9507: #             number) or 'incompatible' via
 9508: #             _types_are_compatible. $self and
 9509: #             $class are excluded from undocumented
 9510: #             parameter warnings in appropriate
 9511: #             context.
 9512: # --------------------------------------------------
 9513: sub _validate_pod_code_agreement {
●9514 → 9521 → 9582 9514: 	my ($self, $pod_params, $code_params, $method_name) = @_;
 9515: 
 9516: 	my @errors;
 9517: 
 9518: 	# Get all parameter names from both sources
 9519: 	my %all_params = map { $_ => 1 } (keys %$pod_params, keys %$code_params);
 9520: 
 9521: 	foreach my $param (sort keys %all_params) {
 9522: 		my $pod = $pod_params->{$param} || {};
 9523: 		my $code = $code_params->{$param} || {};
 9524: 
 9525: 		# Params from a =head3|4 Input formal spec are the authoritative API
 9526: 		# definition — they are exempt from POD/code disagreement checks since
 9527: 		# the spec takes precedence over heuristic code analysis.
 9528: 		next if $pod->{_from_input_spec};
 9529: 
 9530: 		# Check if parameter exists in both
 9531: 		if (exists $pod_params->{$param} && !exists $code_params->{$param}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9532: 			push @errors, "Parameter '\$$param' documented in POD but not found in code signature";
 9533: 			next;
 9534: 		}
 9535: 
 9536: 		if(!exists $pod_params->{$param} && exists $code_params->{$param}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9537: 			if($param eq 'class') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9538: 				# $class is the class invocant, not a user-facing parameter
 9539: 				next;
 9540: 			}
 9541: 			if($param eq 'self') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9542: 				# $self is the instance invocant, not a user-facing parameter
 9543: 				next;
 9544: 			}
 9545: 			push @errors, "Parameter '\$$param' found in code but not documented in POD";
 9546: 			next;
 9547: 		}
 9548: 
 9549: 		# Compare types if both exist
 9550: 		if ($pod->{type} && $code->{type} && $pod->{type} ne $code->{type}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9551: 			if (!$self->_types_are_compatible($pod->{type}, $code->{type})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9552: 				push @errors, "Type mismatch for '\$$param': POD says '$pod->{type}', code suggests '$code->{type}' (incompatible)";
 9553: 			} else {
 9554: 				push @errors, "Type difference for '\$$param': POD says '$pod->{type}', code suggests '$code->{type}' (compatible)";
 9555: 			}
 9556: 		}
 9557: 
 9558: 		# Compare optional status if both exist
 9559: 		if (exists $pod->{optional} && exists $code->{optional} &&

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9560: 			$pod->{optional} != $code->{optional}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9561: 			my $pod_status = $pod->{optional} ? 'optional' : 'required';
 9562: 			my $code_status = $code->{optional} ? 'optional' : 'required';
 9563: 			push @errors, "Optional status mismatch for '\$$param': POD says '$pod_status', code suggests '$code_status'";
 9564: 		}
 9565: 
 9566: 		# Check constraints (min/max)
 9567: 		if (defined $pod->{min} && defined $code->{min} && $pod->{min} != $code->{min}) {

					

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

 9568: 			push @errors, "Min constraint mismatch for '\$$param': POD says '$pod->{min}', code suggests '$code->{min}'";
 9569: 		}
 9570: 
 9571: 		if (defined $pod->{max} && defined $code->{max} && $pod->{max} != $code->{max}) {

					

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

 9572: 			push @errors, "Max constraint mismatch for '\$$param': POD says '$pod->{max}', code suggests '$code->{max}'";
 9573: 		}
 9574: 
 9575: 		# Check regex patterns
 9576: 		if ($pod->{matches} && $code->{matches} && $pod->{matches} ne $code->{matches}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9577: 			push @errors, "Pattern mismatch for '\$$param': POD says '$pod->{matches}', code suggests '$code->{matches}'";
 9578: 		}
 9579: 	}
 9580: 
 9581: 	# Return errors (empty array if no errors)
 9582: 	return @errors;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9583: }
 9584: 
 9585: # --------------------------------------------------
 9586: # _validate_strictness_level
 9587: #
 9588: # Purpose:    Validate and normalise the strict_pod
 9589: #             option value accepted by new() into
 9590: #             an integer level: 0 (off), 1 (warn),
 9591: #             or 2 (fatal).
 9592: #
 9593: # Entry:      $val - the raw value passed to
 9594: #                    strict_pod in new(). May be
 9595: #                    undef, a number, or a string.
 9596: #
 9597: # Exit:       Returns 0, 1, or 2.
 9598: #             Croaks if the value is not recognised.
 9599: #
 9600: # Side effects: None.
 9601: # --------------------------------------------------
 9602: sub _validate_strictness_level {
 9603: 	my $val = $_[0];
 9604: 
 9605: 	return 0 unless defined $val;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9606: 
 9607: 	# Numeric
 9608: 	return 0 if $val =~ /^(0|off|none)$/i;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9609: 	return 1 if $val =~ /^(1|warn|warning)$/i;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9610: 	return 2 if $val =~ /^(2|fatal|die|error)$/i;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9611: 
 9612: 	croak("Invalid value for --strict-pod: '$val' (use off|warn|fatal)");
 9613: }
 9614: 
 9615: # --------------------------------------------------
 9616: # _types_are_compatible
 9617: #
 9618: # Purpose:    Determine whether two type strings
 9619: #             are compatible for POD/code agreement
 9620: #             checking, allowing semantically
 9621: #             equivalent types (e.g. 'integer' and
 9622: #             'number') to coexist without
 9623: #             triggering a strict POD warning.
 9624: #
 9625: # Entry:      $pod_type  - type string from POD.
 9626: #             $code_type - type string from code.
 9627: #
 9628: # Exit:       Returns 1 if compatible, 0 otherwise.
 9629: #
 9630: # Side effects: None.
 9631: # --------------------------------------------------
 9632: sub _types_are_compatible {
●9633 → 9649 → 9654 9633: 	my ($self, $pod_type, $code_type) = @_;
 9634: 
 9635: 	# Exact match is always compatible
 9636: 	return 1 if $pod_type eq $code_type;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9637: 
 9638: 	# Define compatibility matrix
 9639: 	my %compatible_types = (
 9640: 		'integer' => ['number', 'scalar'],
 9641: 		'number' => ['scalar'],
 9642: 		'string' => ['scalar'],
 9643: 		'scalar' => ['string', 'integer', 'number'],
 9644: 		'arrayref' => ['array'],
 9645: 		'hashref' => ['hash'],
 9646: 	);
 9647: 
 9648: 	# Check if code_type is compatible with pod_type
 9649: 	if (my $allowed = $compatible_types{$pod_type}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9650: 		return grep { $_ eq $code_type } @$allowed;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9651: 	}
 9652: 
 9653: 	# Check if pod_type is compatible with code_type
●9654 → 9654 → 9658 9654: 	if (my $allowed = $compatible_types{$code_type}) {

					

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

 9655: 		return grep { $_ eq $pod_type } @$allowed;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9656: 	}
 9657: 
 9658: 	return 0;	# Not compatible

					

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

 9659: }
 9660: 
 9661: =head2 generate_pod_validation_report
 9662: 
 9663: Generate a human-readable report of all POD/code disagreements found
 9664: across a set of extracted schemas.
 9665: 
 9666:     my $schemas = $extractor->extract_all(no_write => 1);
 9667:     my $report  = $extractor->generate_pod_validation_report($schemas);
 9668:     print $report;
 9669: 
 9670: =head3 Arguments
 9671: 
 9672: =over 4
 9673: 
 9674: =item * C<$schemas>
 9675: 
 9676: A hashref of method name to schema hashref as returned by
 9677: C<extract_all>. Required.
 9678: 
 9679: =back
 9680: 
 9681: =head3 Returns
 9682: 
 9683: A string containing the full validation report, or a single line
 9684: confirming all methods passed if no disagreements were found.
 9685: 
 9686: =head3 Side effects
 9687: 
 9688: None.
 9689: 
 9690: =head3 Notes
 9691: 
 9692: Only methods whose schemas contain a C<_pod_validation_errors> key
 9693: (populated when C<strict_pod> is 1 or 2) appear in the report. If
 9694: C<strict_pod> was 0 when C<extract_all> was called, this method will
 9695: always return the all-passed message.
 9696: 
 9697: =head3 API specification
 9698: 
 9699: =head4 input
 9700: 
 9701:     {
 9702:         self    => { type => OBJECT,  isa => 'App::Test::Generator::SchemaExtractor' },
 9703:         schemas => { type => HASHREF },
 9704:     }
 9705: 
 9706: =head4 output
 9707: 
 9708:     { type => SCALAR }
 9709: 
 9710: =cut
 9711: 
 9712: sub generate_pod_validation_report {
●9713 → 9716 → 9728 9713: 	my ($self, $schemas) = @_;
 9714: 
 9715: 	my @reports;
 9716: 	foreach my $method_name (sort keys %$schemas) {
 9717: 		my $schema = $schemas->{$method_name};
 9718: 
 9719: 		if (my $errors = $schema->{_pod_validation_errors}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9720: 			push @reports, "Method: $method_name";
 9721: 			push @reports, "  Severity: " . ($schema->{_pod_disagreement} ? 'warning' : 'fatal');
 9722: 			push @reports, "  Errors:";
 9723: 			push @reports, map { "    - $_" } @$errors;
 9724: 			push @reports, '';
 9725: 		}
 9726: 	}
 9727: 
●9728 → 9728 → 0 9728: 	if (@reports) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 9729: 		return join("\n", "POD/Code Validation Report:", '=' x 40, '', @reports);

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9730: 	} else {
 9731: 		return 'POD/Code Validation: All methods passed consistency checks.';

  Mutants (Total: 2, Killed: 2, Survived: 0)
 9732: 	}
 9733: }
 9734: 
 9735: =head2 _log
 9736: 
 9737: Log a message if verbose mode is on.
 9738: 
 9739: =cut
 9740: 
 9741: sub _log {
 9742: 	my($self, $msg) = @_;
 9743: 
 9744: 	print "$msg\n" if $self->{verbose};
 9745: }
 9746: 
 9747: =head1 NOTES
 9748: 
 9749: This is pre-pre-alpha proof of concept code.
 9750: Nevertheless,
 9751: it is useful for creating a template which you can modify to create a working schema to pass into L<App::Test::Generator>.
 9752: 
 9753: =head1 TODO
 9754: 
 9755: Extend C<=head4 Input> parsing to cover the C<enum>/C<memberof> constraint
 9756: synonym (union types, e.g. C<scalar | scalarref>, are already handled by
 9757: C<_map_formal_input_type>).
 9758: 
 9759: =head1 SEE ALSO
 9760: 
 9761: =over 4
 9762: 
 9763: =item * L<App::Test::Generator> - Generate fuzz and corpus-driven test harnesses
 9764: 
 9765: Output from this module serves as input to that module.
 9766: So with well-documented code, you can automatically create your tests.
 9767: 
 9768: =item * L<App::Test::Generator::Template> - Template of the file of tests created by C<App::Test::Generator>
 9769: 
 9770: =back
 9771: 
 9772: =head1 AUTHOR
 9773: 
 9774: Nigel Horne, C<< <njh at nigelhorne.com> >>
 9775: 
 9776: =head1 LICENCE AND COPYRIGHT
 9777: 
 9778: Copyright 2025-2026 Nigel Horne.
 9779: 
 9780: Usage is subject to GPL2 licence terms.
 9781: If you use it,
 9782: please let me know.
 9783: 
 9784: =cut
 9785: 
 9786: 1;