File Coverage

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

line	stmt	bran	cond	sub	time	code
1						package App::Test::Generator::SchemaExtractor;
2
3	34 34 34			34	1491535 32 518	use strict;
4	34 34 34			34	52 25 653	use warnings;
5	34 34 34			34	5090 179292 66	use autodie qw(:all);
6
7	34 34 34			34	248430 64 546	use App::Test::Generator::Model::Method;
8	34 34 34			34	5046 44 534	use App::Test::Generator::Analyzer::Complexity;
9	34 34 34			34	4613 45 488	use App::Test::Generator::Analyzer::Return;
10	34 34 34			34	4281 42 509	use App::Test::Generator::Analyzer::ReturnMeta;
11	34 34 34			34	4585 45 530	use App::Test::Generator::Analyzer::SideEffect;
12
13	34 34 34			34	68 25 727	use Carp qw(carp croak);
14	34 34 34			34	5715 1981776 568	use PPI;
15	34 34 34			34	5765 442398 569	use Pod::Simple::Text;
16	34 34 34			34	100 29 1261	use File::Basename;
17	34 34 34			34	71 31 717	use File::Path qw(make_path);
18	34 34 34			34	5891 93310 812	use Params::Get;
19	34 34 34			34	7064 144417 556	use Safe;
20	34 34 34			34	81 28 725	use Scalar::Util qw(looks_like_number);
21	34 34 34			34	4071 32095 872	use YAML::XS;
22	34 34 34			34	6451 40812 906	use IPC::Open3;
23	34 34 34			34	91 30 946	use JSON::MaybeXS qw(encode_json decode_json);
24	34 34 34			34	74 27 516	use Readonly;
25	34 34 34			34	58 32 810774	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						# Patterns for rejecting dangerous signature expressions
54						# in _compile_signature_isolated
55						# --------------------------------------------------
56						Readonly my $UNSAFE_KEYWORD_RE => qr/\b(?:system\|exec\|open\|fork\|require\|do\|eval\|qx)\b/;
57						Readonly my $UNSAFE_CHAR_RE => qr/[`{};]/;
58
59						# --------------------------------------------------
60						# strict_pod levels â€” integer values stored internally
61						# but referred to by name everywhere in code
62						# --------------------------------------------------
63						Readonly my $STRICT_POD_OFF => 0;
64						Readonly my $STRICT_POD_WARN => 1;
65						Readonly my $STRICT_POD_FATAL => 2;
66
67						# --------------------------------------------------
68						# Numeric boundary values for test hint generation
69						# --------------------------------------------------
70						Readonly my $INT32_MAX => 2_147_483_647;
71
72						# --------------------------------------------------
73						# Boolean return score thresholds
74						# --------------------------------------------------
75						Readonly my $BOOLEAN_SCORE_THRESHOLD => 30;
76
77 - 85						=head1 NAME App::Test::Generator::SchemaExtractor - Extract test schemas from Perl modules =head1 VERSION Version 0.46 =cut
86
87						our $VERSION = '0.46';
88
89 - 1349						=head1 SYNOPSIS use App::Test::Generator::SchemaExtractor; my $extractor = App::Test::Generator::SchemaExtractor->new( input_file => 'lib/MyModule.pm', output_dir => 'schemas/', verbose => 1, ); my $schemas = $extractor->extract_all(); =head1 DESCRIPTION App::Test::Generator::SchemaExtractor analyzes Perl modules and generates structured YAML schema files suitable for automated test generation by L<App::Test::Generator>. This module employs static analysis techniques to infer parameter types, constraints, and method behaviors directly from your source code. =head2 Analysis Methods The extractor combines multiple analysis approaches for a comprehensive schema generation: =over 4 =item * B<POD Documentation Analysis> Parses embedded documentation to extract: - Parameter names, types, and descriptions from =head2 sections - Method signatures with positional parameters - Return value specifications from "Returns:" sections - Constraints (ranges, patterns, required/optional status) - Semantic type detection (email, URL, filename) =item * B<Code Pattern Detection> Analyzes source code using PPI to identify: - Method signatures and parameter extraction patterns - Type validation (ref(), isa(), blessed()) - Constraint patterns (length checks, numeric comparisons, regex matches) - Return statement analysis and value type inference - Object instantiation requirements and accessor methods =item * B<Signature Analysis> Examines method declarations for: - Parameter names and positional information - Instance vs. class method detection - Method modifiers (Moose-style before/after/around) - Various parameter declaration styles (shift, @_ assignment) =item * B<Heuristic Inference> Applies Perl-specific domain knowledge: - Boolean return detection from method names (is_, has_, can_) - Common Perl idioms and coding patterns - Context awareness (scalar vs list, wantarray usage) - Object-oriented patterns (constructors, accessors, chaining) =back =head2 Generated Schema Structure The extracted schemas follow this YAML structure: function: method_name module: Package::Name input: param1: type: string min: 3 max: 50 optional: 0 position: 0 param2: type: integer min: 0 max: 100 optional: 1 position: 1 output: type: boolean value: 1 new: Package::Name # if object instantiation required config: test_empty: 1 test_nuls: 0 test_undef: 0 test_non_ascii: 0 =head2 Advanced Detection Capabilities =over 4 =item B<Accessor Method Detection> Automatically identifies getter, setter, and combined accessor methods by analyzing common patterns like C<return $self-E<gt>{property}> and C<$self-E<gt>{property} = $value>. =item * B<Params::Get Integration> Recognises parameters extracted via C<Params::Get::get_params('key', \@_)>, treating the quoted key as a named parameter equivalent to a traditional C<my ($self, $key) = @_> signature. This prevents false positives from C<--strict-pod> when the method body never declares an explicit C<$key> variable. =item * B<Direct-Index Self Style> Recognises C<my $self = $_[0]> as a valid method-invocant pattern. Parameters at C<$_[1]>, C<$_[2]>, etc. are extracted as positional parameters. Without this, the signature fallback would incorrectly pick up C<my (...) = @_> from inner closures defined in the method body and treat those variables as the outer method's parameters. =item * B<Boolean Return Inference> Detects boolean-returning methods through multiple signals: - Method name patterns (is_, has_, can_) - Return patterns (consistent 1/0 returns) - POD descriptions ("returns true on success") - Ternary operators with boolean results =item B<Context Awareness> Identifies methods that use C<wantarray> and can return different values in scalar vs list context. =item * B<Object Lifecycle Management> Detects instance methods requiring object instantiation and automatically adds the C<new> field to schemas. =item * B<Enhanced Object Detection> The extractor includes sophisticated object detection capabilities that go beyond simple instance method identification: =over 4 =item * B<Factory Method Recognition> 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. =item * B<Singleton Pattern Detection> 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. =item * B<Constructor Parameter Analysis> 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. =item * B<Inheritance Relationship Handling> 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. =item * B<External Object Dependency Detection> Identifies when methods create or depend on objects from other classes, enabling proper test setup with mock objects or real dependencies. =back These enhancements ensure that generated test schemas accurately reflect the object-oriented structure of the code, leading to more meaningful and effective test generation. =back =head2 Confidence Scoring Each generated schema includes detailed confidence assessments: =over 4 =item * B<High Confidence> Multiple independent analysis sources converge on consistent, well-constrained parameters with explicit validation logic and comprehensive documentation. =item * B<Medium Confidence> Reasonable evidence from code patterns or partial documentation, but may lack comprehensive constraints or have some ambiguities. =item * B<Low Confidence> Minimal evidence - primarily based on naming conventions, default assumptions, or single-source analysis. =item * B<Very Low Confidence> Barely any detectable signals - schema should be thoroughly reviewed before use in test generation. =back =head2 Use Cases =over 4 =item * B<Automated Test Generation> Generate comprehensive test suites with L<App::Test::Generator> using extracted schemas as input. The schemas provide the necessary structure for generating both positive and negative test cases. =item * B<API Documentation Generation> Supplement existing documentation with automatically inferred interface specifications, parameter requirements, and return types. =item * B<Code Quality Assessment> Identify methods with poor documentation, inconsistent parameter handling, or unclear interfaces that may benefit from refactoring. =item * B<Refactoring Assistance> Detect method dependencies, object instantiation requirements, and parameter usage patterns to inform refactoring decisions. =item * B<Legacy Code Analysis> Quickly understand the interface contracts of legacy Perl codebases without extensive manual code reading. =back =head2 Integration with Testing Ecosystem The generated schemas are specifically designed to work with the L<App::Test::Generator> ecosystem: # Extract schemas from your module my $extractor = App::Test::Generator::SchemaExtractor->new(...); my $schemas = $extractor->extract_all(); # Use with test generator (typically as separate steps) # fuzz-harness-generator -r schemas/method_name.yml =head2 Limitations and Considerations =over 4 =item * B<Dynamic Code Patterns> Highly dynamic code (string evals, AUTOLOAD, symbolic references) may not be fully detected by static analysis. =item * B<Complex Validation Logic> Sophisticated validation involving multiple parameters or external dependencies may require manual schema refinement. =item * B<Confidence Heuristics> Confidence scores are based on heuristics and should be reviewed by developers familiar with the codebase. =item * B<Perl Idiom Recognition> Some Perl-specific idioms may require custom pattern recognition beyond the built-in detectors. =item * B<Documentation Dependency> Analysis quality improves significantly with comprehensive POD documentation following consistent patterns. =back =head2 Best Practices for Optimal Results =over 4 =item * B<Comprehensive POD Documentation> Write detailed POD with explicit parameter documentation using consistent patterns like C<$param - type (constraints), description>. =item * B<Consistent Coding Patterns> Use consistent parameter validation patterns and method signatures throughout your codebase. =item * B<Schema Review Process> Review and refine automatically generated schemas, particularly those with low confidence scores. =item * B<Descriptive Naming> Use descriptive method and parameter names that clearly indicate purpose and expected types. =item * B<Progressive Enhancement> Start with automatically generated schemas and progressively refine them based on test results and code understanding. =back The module is particularly valuable for large codebases where manual schema creation would be prohibitively time-consuming, and for maintaining test coverage as code evolves through continuous integration pipelines. =head2 Advanced Type Detection The schema extractor includes enhanced type detection capabilities that identify specialized Perl types beyond basic strings and integers. 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. 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. 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. =head3 Example Advanced Type Schema For a method like: sub process_event { my ($self, $timestamp, $status, $callback) = @_; croak unless $timestamp > 1000000000; croak unless $status =~ /^(active\|pending\|complete)$/; croak unless ref($callback) eq 'CODE'; $callback->($timestamp, $status); } The extractor generates: --- function: process_event module: MyModule input: timestamp: type: integer # min: 0 # max: 2147483647 position: 0 _note: Unix timestamp semantic: unix_timestamp status: type: string enum: - active - pending - complete position: 1 _note: 'Must be one of: active, pending, complete' callback: type: coderef position: 2 _note: 'CODE reference - provide sub { } in tests' =head1 RELATIONSHIP DETECTION The schema extractor detects relationships and dependencies between parameters, enabling more sophisticated validation and test generation. =head2 Relationship Types =over 4 =item * B<mutually_exclusive> Parameters that cannot be used together. die if $file && $content; # Can't specify both Generated schema: relationships: - type: mutually_exclusive params: [file, content] description: Cannot specify both file and content =item * B<required_group> At least one parameter from the group must be specified (OR logic). die unless $id \|\| $name; # Must provide one Generated schema: relationships: - type: required_group params: [id, name] logic: or description: Must specify either id or name =item * B<conditional_requirement> If one parameter is specified, another becomes required (IF-THEN logic). die if $async && !$callback; # async requires callback Generated schema: relationships: - type: conditional_requirement if: async then_required: callback description: When async is specified, callback is required =item * B<dependency> One parameter depends on another being present. die "Port requires host" if $port && !$host; Generated schema: relationships: - type: dependency param: port requires: host description: port requires host to be specified =item * B<value_constraint> Specific value requirements between parameters. die if $ssl && $port != 443; # ssl requires port 443 Generated schema: relationships: - type: value_constraint if: ssl then: port operator: == value: 443 description: When ssl is specified, port must equal 443 =item * B<value_conditional> Parameter required when another has a specific value. die if $mode eq 'secure' && !$key; Generated schema: relationships: - type: value_conditional if: mode equals: secure then_required: key description: When mode equals 'secure', key is required =back =head2 Default Value Extraction The extractor comprehensively extracts default values from both code and POD documentation: =head3 Code Pattern Recognition Extracts defaults from multiple Perl idioms: =over 4 =item * Logical OR operator: C<$param = $param \|\| 'default'> =item * Defined-or operator: C<$param //= 'default'> =item * Ternary operator: C<$param = defined $param ? $param : 'default'> =item * Unless conditional: C<$param = 'default' unless defined $param> =item * Chained defaults: C<$param = $param \|\| $self->{_default} \|\| 'fallback'> =item * Multi-line patterns: C<$param = {} unless $param> =back =head3 POD Pattern Recognition Extracts defaults from documentation: =over 4 =item * Standard format: C<Default: 'value'> =item * Alternative format: C<Defaults to: 'value'> =item * Inline format: C<Optional, default: 'value'> =item * Parameter lists: C<$param - type, default 'value'> =back =head3 Value Processing Properly handles: =over 4 =item * String literals with quotes and escape sequences =item * Numeric values (integers and floats) =item * Boolean values (true/false converted to 1/0) =item * Empty data structures ([] and {}) =item * Special values (undef, __PACKAGE__) =item * Complex expressions (preserved as-is when unevaluatable) =item * Quote operators (q{}, qq{}, qw{}) =back =head3 Type Inference When a parameter has a default value but no explicit type annotation, the type is automatically inferred from the default: $options = {} # inferred as hashref $items = [] # inferred as arrayref $count = 42 # inferred as integer $ratio = 3.14 # inferred as number $enabled = 1 # inferred as boolean =head2 Context-Aware Return Analysis The extractor provides comprehensive analysis of method return behavior, including context sensitivity, error handling conventions, and method chaining patterns. When a method's POD contains a C<=head4 Output> block in L<Params::Validate::Strict> schema format, the C<type> declared there is used as the authoritative output type and takes precedence over all heuristic code analysis: =head4 Output { type => 'hashref', } This is the recommended way to document methods whose return type would otherwise be misidentified (e.g. a method that returns C<$self-E<gt>{cache}> where the cache happens to hold a hashref). Using parentheses as the outer container emits C<type: array>, indicating a list-returning method. L<App::Test::Generator> 0.39+ (with L<Test::Returns> 0.03+) captures these results in list context automatically: =head4 Output ( { type => 'hashref', }, ... ) =head3 List vs Scalar Context Detection Automatically detects methods that return different values based on calling context: sub get_items { my $self = $_[0]; return wantarray ? @items : scalar(@items); } Detection captures: =over 4 =item * C<_context_aware> flag - Method uses wantarray =item * C<_list_context> - Type returned in list context (e.g., 'array') =item * C<_scalar_context> - Type returned in scalar context (e.g., 'integer') =back Recognizes both ternary operator patterns and conditional return patterns. =head3 Void Context Methods Identifies methods that don't return meaningful values: =over 4 =item * Setters (C<set_> methods) =item Mutators (C<add_, remove_, delete_, clear_, reset_, update_>) =item * Loggers (C<log, debug, warn, error, info>) =item * Methods with only empty returns =back Example: sub set_name { my ($self, $name) = @_; $self->{name} = $name; return; # Void context } Sets C<_void_context> flag and C<type =E<gt> 'void'>. =head3 Method Chaining Detection Identifies chainable methods that return C<$self> for fluent interfaces: sub set_width { my ($self, $width) = @_; $self->{width} = $width; return $self; # Chainable } Detection provides: =over 4 =item * C<_returns_self> - Returns invocant for chaining =item * C<class> - The class name being returned =back Also detects chaining documentation in POD (keywords: "chainable", "fluent interface", "returns self", "method chaining"). =head3 Error Return Conventions Analyzes how methods signal errors: B<Pattern Detection:> =over 4 =item * C<undef_on_error> - Explicit C<return undef if/unless condition> =item * C<implicit_undef> - Bare C<return if/unless condition> =item * C<empty_list> - C<return ()> for list context errors =item * C<zero_on_error> - Returns 0/false for boolean error indication =item * C<exception_handling> - Uses eval blocks with error checking =back B<Example Analysis:> sub fetch_user { my ($self, $id) = @_; return undef unless $id; # undef_on_error return undef if $id < 0; # undef_on_error return $self->{users}{$id}; } Results in: _error_return: 'undef' _success_failure_pattern: 1 _error_handling: { undef_on_error: ['$id', '$id < 0'] } B<Success/Failure Pattern:> Methods that return different types for success vs. failure are flagged with C<_success_failure_pattern>. Common patterns: =over 4 =item * Returns value on success, undef on failure =item * Returns true on success, false on failure =item * Returns data on success, empty list on failure =back =head3 Success Indicator Detection Methods that always return true (typically for side effects): sub update_status { my ($self, $status) = @_; $self->{status} = $status; return 1; # Success indicator } Sets C<_success_indicator> flag when method consistently returns 1. =head3 Schema Output Enhanced return analysis adds these fields to method schemas: output: type: boolean # Inferred return type _context_aware: 1 # Uses wantarray _list_context: type: array _scalar_context: type: integer _returns_self: 1 # Returns $self _void_context: 1 # No meaningful return _success_indicator: 1 # Always returns true _error_return: undef # How errors are signaled _success_failure_pattern: 1 # Mixed return types _error_handling: # Detailed error patterns undef_on_error: [...] exception_handling: 1 This comprehensive analysis enables: =over 4 =item * Better test generation (testing both contexts, error paths) =item * Documentation generation (clear error conventions) =item * API design validation (consistent error handling) =item * Contract specification (precise return behavior) =back =head2 Example For a method like: sub connect { my ($self, $host, $port, $ssl, $file, $content) = @_; die if $file && $content; # mutually exclusive die unless $host \|\| $file; # required group die "Port requires host" if $port && !$host; # dependency die if $ssl && $port != 443; # value constraint # ... connection logic } The extractor generates: relationships: - type: mutually_exclusive params: [file, content] description: Cannot specify both file and content - type: required_group params: [host, file] logic: or description: Must specify either host or file - type: dependency param: port requires: host description: port requires host to be specified - type: value_constraint if: ssl then: port operator: == value: 443 description: When ssl is specified, port must equal 443 =head1 MODERN PERL FEATURES This module adds support for: =head2 Subroutine Signatures (Perl 5.20+) sub connect($host, $port = 3306, %options) { ... } Extracts: required params, optional params with defaults, slurpy params =head2 Type Constraints (Perl 5.36+) sub calculate($x :Int, $y :Num) { ... } Recognizes: Int, Num, Str, Bool, ArrayRef, HashRef, custom classes =head3 Subroutine Attributes sub get_value :lvalue :Returns(Int) { ... } Detects: :lvalue, :method, :Returns(Type), custom attributes =head2 Postfix Dereferencing (Perl 5.20+) my @array = $arrayref->@; my %hash = $hashref->%; my @slice = $arrayref->@[1,3,5]; Tracks usage of modern dereferencing syntax =head2 Field Declarations (Perl 5.38+) field $host :param = 'localhost'; field $port :param(port_number) = 3306; field $logger :param :isa(Log::Any); Extracts fields and maps them to parameters =head2 Modern Perl Features Support The schema extractor supports modern Perl syntax introduced in versions 5.20, 5.36, and 5.38+. =head3 Subroutine Signatures (Perl 5.20+) Automatically extracts parameters from native Perl signatures: use feature 'signatures'; sub connect($host, $port = 3306, $database = undef) { ... } Extracted schema includes: =over 4 =item * Parameter positions =item * Optional vs required parameters =item * Default values from signature =item * Slurpy parameters (@array, %hash) =back B<Example:> # Signature with defaults sub process($file, %options) { ... } # Extracts: # $file: position 0, required # %options: position 1, optional, slurpy hash =head3 Type Constraints in Signatures (Perl 5.36+) Recognizes type constraints in signature parameters: sub calculate($x :Int, $y :Num, $name :Str = "result") { return $x + $y; } Supported constraint types: =over 4 =item * C<:Int, :Integer> -> integer =item * C<:Num, :Number> -> number =item * C<:Str, :String> -> string =item * C<:Bool, :Boolean> -> boolean =item * C<:ArrayRef, :Array> -> arrayref =item * C<:HashRef, :Hash> -> hashref =item * C<:ClassName> -> object with isa constraint =back Type constraints are combined with defaults when both are present. =head3 Subroutine Attributes Extracts and documents subroutine attributes: sub get_value :lvalue { my $self = shift; return $self->{value}; } sub calculate :Returns(Int) :method { my ($self, $x, $y) = @_; return $x + $y; } Recognized attributes stored in C<_attributes> field: =over 4 =item * C<:lvalue> - Method can be assigned to =item * C<:method> - Explicitly marked as method =item * C<:Returns(Type)> - Declares return type =item * Custom attributes with values: C<:MyAttr(value)> =back =head3 Postfix Dereferencing (Perl 5.20+) Detects usage of postfix dereferencing syntax: use feature 'postderef'; sub process_array { my ($self, $arrayref) = @_; my @array = $arrayref->@; # Array dereference my @slice = $arrayref->@[1,3,5]; # Array slice return @array; } sub process_hash { my ($self, $hashref) = @_; my %hash = $hashref->%; # Hash dereference return keys %hash; } Tracked features stored in C<_modern_features>: =over 4 =item * C<array_deref> - Uses C<-E<gt>@> =item C<hash_deref> - Uses C<-E<gt>%> =item C<scalar_deref> - Uses C<-E<gt>$> =item C<code_deref> - Uses C<-E<gt>&> =item C<array_slice> - Uses C<-E<gt>@[...]> =item * C<hash_slice> - Uses C<-E<gt>%{...}> =back =head3 Field Declarations (Perl 5.38+) Extracts field declarations from class syntax and maps them to method parameters: use feature 'class'; class DatabaseConnection { field $host :param = 'localhost'; field $port :param = 3306; field $username :param(user); field $password :param; field $logger :param :isa(Log::Any); method connect() { # Fields available as instance variables } } Field attributes: =over 4 =item * C<:param> - Field is a constructor parameter (uses field name) =item * C<:param(name)> - Field maps to parameter with different name =item * C<:isa(Class)> - Type constraint for the field =item * Default values in field declarations =back Extracted schema includes both field information in C<_fields> and merged parameter information in C<input>, allowing proper validation of class constructors. =head3 Mixed Modern and Traditional Syntax The extractor handles code that mixes modern and traditional syntax: sub modern($x, $y = 5) { # Modern signature with default } sub traditional { my ($self, $x, $y) = @_; $y //= 5; # Traditional default in code # Both extract same parameter information } Priority order for parameter information: =over 4 =item 1. Signature declarations (highest priority) =item 2. Field declarations (for class methods) =item 3. POD documentation =item 4. Code analysis (lowest priority) =back This ensures that explicit declarations in signatures take precedence over inferred information from code analysis. =head3 Backwards Compatibility All modern Perl feature detection is optional and automatic: =over 4 =item * Traditional C<sub> declarations continue to work =item * Code without modern features extracts parameters as before =item * Modern features are additive - they enhance rather than replace existing extraction =item * Schemas include C<_source> field indicating where parameter info came from =back =head2 _yamltest_hints Each method schema returned by L</extract_all> now optionally includes a C<_yamltest_hints> key, which provides guidance for automated test generation based on the code analysis. This is intended to help L<App::Test::Generator> create meaningful tests, including boundary and invalid input cases, without manually specifying them. The structure is a hashref with the following keys: =over 4 =item * boundary_values An arrayref of numeric values that represent boundaries detected from comparisons in the code. These are derived from literals in statements like C<$x < 0> or C<$y >= 255>. The generator can use these to create boundary tests. Example: _yamltest_hints: boundary_values: [0, 1, 100, 255] =item * invalid_inputs An arrayref of values that are likely to be rejected by the method, based on checks like C<defined>, empty strings, or numeric validations. Example: _yamltest_hints: invalid_inputs: [undef, '', -1] =item * equivalence_classes An arrayref intended to capture detected equivalence classes or patterns among inputs. Currently this is empty by default, but future enhancements may populate it based on detected input groupings. Example: _yamltest_hints: equivalence_classes: [] =back =head3 Usage When calling C<extract_all>, each method schema will include C<_yamltest_hints> if any hints were detected: my $schemas = $extractor->extract_all; my $hints = $schemas->{example_method}->{_yamltest_hints}; You can then feed these hints into automated test generators to produce negative tests, boundary tests, and parameter-specific test cases. =head3 Notes =over 4 =item * Hints are inferred heuristically from code and validation statements. =item * Not all inputs are guaranteed to be detected; the feature is additive and will never remove information from the schema. =item * Currently, equivalence classes are not populated, but the field exists for future extension. =item * Boundary and invalid input hints are deduplicated to avoid repeated test values. =back =head3 Examples Given a method like: sub example { my ($x) = @_; die "negative" if $x < 0; return unless defined($x); return $x * 2; } After running: my $extractor = App::Test::Generator::SchemaExtractor->new( input_file => 'TestHints.pm', output_dir => '/tmp', quiet => 1, ); my $schemas = $extractor->extract_all; The schema for the method "example" will include: $schemas->{example} = { function => 'example', _confidence => { input => 'unknown', output => 'unknown', }, input => { x => { type => 'scalar', optional => 0, } }, output => { type => 'scalar', }, _yamltest_hints => { boundary_values => [0, 1], invalid_inputs => [undef, -1], equivalence_classes => [], }, _notes => '...', _analysis => { input_confidence => 'low', output_confidence => 'unknown', confidence_factors => { input => {...}, output => {...}, }, overall_confidence => 'low', }, _fields => {}, _modern_features => {}, _attributes => {}, }; =head1 METHODS =head2 new Construct a new SchemaExtractor for a given Perl source file. my $extractor = App::Test::Generator::SchemaExtractor->new( input_file => 'lib/MyModule.pm', # Required output_dir => 'schemas/', # Optional - only needed if writing schemas verbose => 1, # Default: 0 include_private => 1, # Default: 0 max_parameters => 50, # Default: 20 confidence_threshold => 0.7, # Default: 0.5 strict_pod => 0\|1\|2, # Default: 0 (off) allow_signature_exec => 1, # Default: 0 (off) ); =head3 Arguments =over 4 =item * C<$input_file> Path to the Perl source file to analyse. Required. Must exist on disk. =item * C<output_dir> Directory to write generated schema YAML files. Optional - only required if C<_write_schema> will be called. Callers passing C<no_write =E<gt> 1> to C<extract_all> do not need to supply it. =item * C<verbose> Print progress messages to stdout during analysis. Optional, default 0. =item * C<include_private> Include methods whose names begin with C<_> in the analysis. Optional, default 0. Methods whose name begins with C<_new>, C<_init>, or C<_build> are always included regardless of this setting (a prefix match, so e.g. C<_build_attribute> and C<_init_logger> qualify too, matching common Moose builder/initializer naming conventions). =item * C<max_parameters> Safety limit on the number of parameters analysed per method to prevent runaway processing on pathological code. Optional, default 20. =item * C<confidence_threshold> Minimum confidence score (0.0-1.0) below which a schema is marked with C<_low_confidence =E<gt> 1>. Optional, default 0.5. =item * C<strict_pod> Controls POD/code agreement validation. C<0> disables validation, C<1> emits warnings, C<2> croaks on first disagreement. Also accepts the strings C<off>, C<warn>, and C<fatal>. Optional, default 0. =item * C<allow_signature_exec> Opt-in flag allowing extraction of parameter types from a L<Type::Params> C<signature_for()> declaration. This requires actually running the C<signature_for> expression (sliced from the target module's own source) in a forked C<perl -T> process, since L<Type::Params> types are runtime objects that cannot be introspected statically. Every other extraction path in this module is static (L<PPI>-only) analysis that never executes any of the target module's code; this is the one exception. Optional, default 0 (the C<signature_for> path is silently skipped, with a warning under C<verbose>, when off). Only enable this for modules whose code you already trust enough to execute. =back =head3 Returns A blessed hashref. Croaks if C<input_file> is missing or does not exist on disk. =head3 Side effects Reads and parses the input file using L<PPI> at construction time. =head3 API specification =head4 input { input_file => { type => SCALAR }, output_dir => { type => SCALAR, optional => 1 }, verbose => { type => SCALAR, optional => 1 }, include_private => { type => SCALAR, optional => 1 }, max_parameters => { type => SCALAR, optional => 1 }, confidence_threshold => { type => SCALAR, optional => 1 }, strict_pod => { type => SCALAR, optional => 1 }, allow_signature_exec => { type => SCALAR, optional => 1 }, } =head4 output { type => OBJECT, isa => 'App::Test::Generator::SchemaExtractor', } =cut
1350
1351						sub new {
1352	489			489	3240819	my $class = shift;
1353
1354						# Handle hash or hashref arguments
1355	489		50		929	my $params = Params::Get::get_params('input_file', @_) \|\| {};
1356
1357	486	50			6908	croak(__PACKAGE__, ': input_file required') unless exists $params->{input_file};
1358
1359						my $self = {
1360						input_file => $params->{input_file},
1361						# output_dir is optional â€” only required if _write_schema will be called.
1362						# Callers using extract_all(no_write => 1) do not need to supply it.
1363						output_dir => $params->{output_dir},
1364						verbose => $params->{verbose} // 0,
1365						include_private => $params->{include_private} // 0, # include _private methods
1366						confidence_threshold => $params->{confidence_threshold} // $DEFAULT_CONFIDENCE_THRESH,
1367						max_parameters => $params->{max_parameters} // $DEFAULT_MAX_PARAMETERS, # safety limit
1368						strict_pod => _validate_strictness_level($params->{strict_pod}), # Enable strict POD checking
1369	486		50 100 100 67 67		2272	allow_signature_exec => $params->{allow_signature_exec} // 0, # opt-in: execute Type::Params signature_for() exprs from the target module
1370						};
1371
1372						# Validate input file exists
1373	486	100			3735	unless (-f $self->{input_file}) {
1374	3				59	croak(__PACKAGE__, ": Input file '$self->{input_file}' does not exist");
1375						}
1376
1377	483				1151	return bless $self, $class;
1378						}
1379
1380 - 1453						=head2 extract_all Extract schemas for all qualifying methods in the module and return them as a hashref. my $schemas = $extractor->extract_all(); # Suppress writing .yml files to disk my $schemas = $extractor->extract_all(no_write => 1); =head3 Arguments =over 4 =item * C<no_write> When true, schema files are not written to C<output_dir>. The returned hashref is still fully populated. Useful when the caller wants to inspect or augment schemas before deciding whether to write them. Optional, default 0. =back =head3 Returns A hashref mapping method name strings to schema hashrefs. Each schema contains at minimum the keys C<function>, C<module>, C<input>, C<output>, and C<_analysis>. See L</Generated Schema Structure> for the full structure. =head3 Side effects Parses the input file with L<PPI>. Writes one YAML file per method to C<output_dir> unless C<no_write> is set. Creates C<output_dir> if it does not exist and writing is enabled. =head3 Notes Private methods (names beginning with C<_>) are excluded unless C<include_private =E<gt> 1> was passed to C<new>. Duplicate method names are deduplicated with a warning logged to stdout in verbose mode. POD/code agreement validation is applied if C<strict_pod> was set in C<new>. At level 2 (fatal), the first disagreement causes an immediate croak. =head3 API specification =head4 input { self => { type => OBJECT, isa => 'App::Test::Generator::SchemaExtractor' }, no_write => { type => SCALAR, optional => 1 }, } =head4 output { type => HASHREF, keys => { '*' => { type => HASHREF, keys => { function => { type => SCALAR }, module => { type => SCALAR }, input => { type => HASHREF }, output => { type => HASHREF }, _analysis => { type => HASHREF }, }, }, }, } =cut
1454
1455						sub extract_all {
1456	115			115	3295	my $self = shift;
1457	115		100		191	my $params = Params::Get::get_params(undef, @_) \|\| {};
1458
1459	115				1484	$self->_log("Parsing $self->{input_file}...");
1460	115				249	$self->_log('Strict POD mode: ' . (qw(off warn fatal))[$self->{strict_pod}]);
1461
1462						# $! is not meaningful here â€” PPI does not set errno on failure
1463						my $document = PPI::Document->new($self->{input_file})
1464	115	50			490	or croak "Failed to parse $self->{input_file}";
1465
1466						# Store document for later use
1467	115				1064947	$self->{_document} = $document;
1468
1469	115				311	my $package_name = $self->_extract_package_name($document);
1470	115		67		1113	$self->{_package_name} //= $package_name;
1471	115				273	$self->_log("Package: $package_name");
1472
1473	115				178	my $methods = $self->_find_methods($document);
1474	115				272	$self->_log('Found ' . scalar(@$methods) . ' methods (pre-dedup)');
1475
1476	115				100	my %schemas;
1477	115 115				102 141	foreach my $method (@{$methods}) {
1478	332				629	$self->_log("\nAnalyzing method: $method->{name}");
1479
1480	332				480	my $schema = $self->_analyze_method($method);
1481	331				508	$schemas{$method->{name}} = $schema;
1482	331				434	$schema->{'module'} = $package_name;
1483
1484						# Write individual schema file
1485						# Only write schema files if no_write is not set
1486	331	100			639	$self->_write_schema($method->{name}, $schema) unless $params->{no_write};
1487						}
1488
1489	114				620	return \%schemas;
1490						}
1491
1492						# --------------------------------------------------
1493						# _extract_package_name
1494						#
1495						# Purpose: Extract the Perl package name from a
1496						# PPI document, or from the cached value
1497						# stored at construction time.
1498						#
1499						# Entry: $document - a PPI::Document, or undef
1500						# to use $self->{_document}.
1501						#
1502						# Exit: Returns the package namespace string,
1503						# or an empty string if no package
1504						# statement is found.
1505						#
1506						# Side effects: Stores the package name in
1507						# $self->{_package_name} if not already
1508						# set.
1509						#
1510						# Notes: Croaks if more than one package
1511						# declaration is found â€” multi-package
1512						# files are not supported.
1513						# --------------------------------------------------
1514						sub _extract_package_name {
1515	139			139	3353	my ($self, $document) = @_;
1516
1517	139	100			190	if(!defined($document)) {
1518	22				24	$document = $self->{_document};
1519						}
1520	139		100		263	my $pkgs = $document->find('PPI::Statement::Package') \|\| [];
1521	139	100			310213	if(@$pkgs == 0) {
1522	8				22	my $package_stmt = $document->find_first('PPI::Statement::Package');
1523	8	50			9310	return $package_stmt ? $package_stmt->namespace() : '';
1524						}
1525	131	50			194	croak('More than one package declaration found') if @$pkgs > 1;
1526	131		67		415	$self->{_package_name} //= $pkgs->[0]->namespace();
1527	131				1516	return $pkgs->[0]->namespace();
1528						}
1529
1530						# --------------------------------------------------
1531						# _find_methods
1532						#
1533						# Purpose: Locate all subroutine and method
1534						# declarations in a PPI document,
1535						# including Moose-style method modifiers
1536						# and Perl 5.38 class/method syntax.
1537						#
1538						# Entry: $document - a PPI::Document.
1539						#
1540						# Exit: Returns an arrayref of method hashrefs,
1541						# each containing: name, node, body, pod,
1542						# type, and optionally modifier, class,
1543						# and fields keys.
1544						# Private methods (names beginning with
1545						# _) are excluded unless include_private
1546						# was set in new(), except for _new,
1547						# _init, and _build which are always
1548						# included.
1549						#
1550						# Side effects: Logs progress and warnings to stdout
1551						# when verbose is set.
1552						#
1553						# Notes: Duplicate method names are silently
1554						# deduplicated â€” the second occurrence
1555						# is dropped with a verbose warning.
1556						# Class/method detection is regex-based
1557						# and may misbehave on complex code.
1558						# --------------------------------------------------
1559						sub _find_methods {
1560	121			121	34716	my ($self, $document) = @_;
1561
1562	121		100		161	my $subs = $document->find('PPI::Statement::Sub') \|\| [];
1563						# Only fetch statements that begin with a Moose modifier keyword â€”
1564						# fetching ALL PPI::Statement nodes on a large file returns thousands
1565						# of nodes and then discards nearly all of them in the loop below.
1566						my $sub_decls = $document->find(sub {
1567	21785			21785	152669	$_[1]->isa('PPI::Statement')
1568						&& $_[1]->content =~ /^\s*(?:before\|after\|around)\b/
1569	121		50		230147	}) \|\| [];
1570
1571	121				811	my @methods;
1572	121				160	foreach my $sub (@$subs) {
1573	358				17388	my $name = $sub->name();
1574
1575	358	50			7797	next unless defined $name; # Skip anonymous routines
1576	358	100			441	next if $name =~ /^(BEGIN\|END\|DESTROY\|AUTOLOAD\|CHECK\|INIT\|UNITCHECK)$/;
1577	356	50			377	next if $name =~ /::/; # cross-package sub (e.g. sub DB::DB { })
1578
1579						# Skip private methods unless explicitly included, or they're special
1580	356	100	100		444	if ($name =~ /^_/ && $name !~ /^_(new\|init\|build)/) {
1581	14	100			27	next unless $self->{include_private};
1582						}
1583
1584						# Get the POD before this sub
1585	345				446	my $pod = $self->_extract_pod_before($sub);
1586
1587	345				415	push @methods, {
1588						name => $name,
1589						node => $sub,
1590						body => $sub->content(),
1591						pod => $pod,
1592						type => 'sub',
1593						};
1594						}
1595
1596						# Look for class { method } syntax (Perl 5.38+)
1597	121				8973	my $content = $document->content();
1598	121	100			30654	if ($content =~ /\bclass\b/) {
1599	27				53	$self->_log(' Detecting class/method syntax...');
1600						# Strip POD blocks and line comments before the regex scan so that
1601						# patterns like class Name { inside documentation examples or
1602						# the comment # find "class Name {" blocks don't produce
1603						# spurious method names (e.g. the keyword 'if').
1604	27				432	(my $code_only = $content) =~ s/^=\w[^\n].?^=cut[^\n]*\n//gms;
1605	27				283	$code_only =~ s/\s#[^\n]//g;
1606	27				70	$self->_extract_class_methods($code_only, \@methods);
1607						}
1608
1609						# Process method modifiers (Moose)
1610	121				192	foreach my $decl (@$sub_decls) {
1611	0				0	my $content = $decl->content;
1612	0	0			0	if ($content =~ /^\s*(before\|after\|around)\s+['"]?(\w+)['"]?\b/) {
1613	0				0	my ($modifier, $method_name) = ($1, $2);
1614	0				0	my $full_name = "${modifier}_$method_name";
1615
1616						# Look for the actual sub definition that follows
1617	0				0	my $next_sib = $decl->next_sibling;
1618	0		0		0	while ($next_sib && !$next_sib->isa('PPI::Statement::Sub')) {
1619	0				0	$next_sib = $next_sib->next_sibling;
1620						}
1621
1622	0	0	0		0	if ($next_sib && $next_sib->isa('PPI::Statement::Sub')) {
1623	0				0	my $pod = $self->_extract_pod_before($decl); # POD might be before modifier
1624	0				0	push @methods, {
1625						name => $full_name,
1626						node => $next_sib,
1627						body => $next_sib->content,
1628						pod => $pod,
1629						type => 'modifier',
1630						original_method => $method_name,
1631						modifier => $modifier,
1632						};
1633	0				0	$self->_log(" Found method modifier: $full_name");
1634						}
1635						}
1636						}
1637
1638						# Prevent silent duplicate method overwrites
1639	121				111	my %seen;
1640						@methods = grep {
1641	121 346				157 278	my $n = $_->{name};
1642	346	100			500	if ($seen{$n}++) {
1643	1				2	$self->_log(" WARNING: duplicate method '$n' ignored");
1644	1				2	0;
1645						} else {
1646	345				353	1;
1647						}
1648						} @methods;
1649
1650	121				238	return \@methods;
1651						}
1652
1653						# --------------------------------------------------
1654						# _extract_class_methods
1655						#
1656						# Purpose: Extract method declarations from
1657						# Perl 5.38 class { method {} } syntax
1658						# by regex-based scanning of the class
1659						# body content.
1660						#
1661						# Entry: $content - full document source string.
1662						# $methods - arrayref to push discovered
1663						# method hashrefs onto
1664						# (modified in place).
1665						#
1666						# Exit: Returns nothing. Appends to $methods.
1667						#
1668						# Side effects: Logs class and method discoveries
1669						# to stdout when verbose is set.
1670						#
1671						# Notes: This is experimental â€” regex-based
1672						# class body parsing may misbehave on
1673						# complex or nested class declarations.
1674						# Class body boundaries are tracked by
1675						# simple brace counting, which will
1676						# fail on unbalanced braces in strings
1677						# or heredocs.
1678						# --------------------------------------------------
1679						sub _extract_class_methods {
1680	28			28	52	my ($self, $content, $methods) = @_;
1681
1682						# EXPERIMENTAL: regex-based parsing, may misbehave on complex code
1683
1684						# Simple pattern: find "class Name {" blocks
1685						# This won't handle all edge cases but will work for simple classes
1686	28				115	while ($content =~ /class\s+(\w+)\s*\{/g) {
1687	2				4	my $class_name = $1;
1688	2				2	my $start_pos = pos($content);
1689
1690						# Find the matching closing brace. $start_pos is just after the
1691						# opening '{' consumed by the regex above, so back up one
1692						# character to hand the brace itself to extract_bracketed.
1693	2				8	require Text::Balanced;
1694	2				6	my $extracted = Text::Balanced::extract_bracketed(substr($content, $start_pos - 1), '{}');
1695
1696	2	50			665	next unless defined $extracted; # unbalanced braces, skip class
1697
1698	2				2	my $class_body = substr($extracted, 1, length($extracted) - 2);
1699
1700	2				5	$self->_log(" Found class $class_name");
1701
1702						# Extract field declarations from class
1703	2				4	my $fields = $self->_extract_field_declarations($class_body);
1704
1705						# Find methods in the class body
1706	2				9	while ($class_body =~ /method\s+(\w+)\s($[^)]$)?\s*\{/g) {
1707	2		50		4	my ($method_name, $sig_with_parens) = ($1, $2 \|\| '()');
1708
1709						# Skip private unless configured
1710	2	50	33		6	if ($method_name =~ /^_/ && $method_name !~ /^_(new\|init\|build)/) {
1711	0	0			0	next unless $self->{include_private};
1712						}
1713
1714						# Reconstruct as sub for analysis
1715	2				2	my $signature = $sig_with_parens;
1716	2				3	$signature =~ s/^\(//;
1717	2				5	$signature =~ s/\)$//;
1718
1719						# Build a fake sub declaration
1720	2				2	my $fake_sub = "sub $method_name($signature) { }";
1721
1722	2				9	push @$methods, {
1723						name => $method_name,
1724						node => undef,
1725						body => $fake_sub, # Just the signature for now
1726						is_stub => 1,
1727						pod => '',
1728						type => 'method',
1729						class => $class_name,
1730						fields => $fields,
1731						};
1732
1733	2				4	$self->_log(" Found method $method_name in class $class_name");
1734						}
1735						}
1736						}
1737
1738						# --------------------------------------------------
1739						# _extract_pod_before
1740						#
1741						# Purpose: Collect the POD documentation that
1742						# appears immediately before a
1743						# subroutine in the PPI document, by
1744						# walking backwards through siblings.
1745						#
1746						# Entry: $sub - a PPI node (typically a
1747						# PPI::Statement::Sub).
1748						#
1749						# Exit: Returns a string containing all POD
1750						# content found before the sub, with
1751						# inline parameter comments converted
1752						# to =item format. Returns an empty
1753						# string if no POD is found.
1754						#
1755						# Side effects: None.
1756						#
1757						# Notes: Stops walking backwards on the first
1758						# non-POD, non-whitespace, non-separator,
1759						# non-include node encountered.
1760						# Walking is capped at $POD_WALK_LIMIT
1761						# steps to prevent runaway processing
1762						# on pathological documents.
1763						# --------------------------------------------------
1764						sub _extract_pod_before {
1765	347			347	3542	my ($self, $sub) = @_;
1766
1767	347				270	my $pod = '';
1768	347				451	my $current = $sub->previous_sibling();
1769	347				4350	my $seen_code = 0;
1770	347				255	my $steps = 0;
1771
1772						# Walk backwards collecting POD.
1773						# Stop after the first pod token so that a =cut before =head1 METHODS
1774						# prevents class-level POD from being mistaken for method-specific POD.
1775	347		67		720	while($current && $steps++ < $POD_WALK_LIMIT) {
1776	871	100 100 100 100	67		7938	if ($current->isa('PPI::Token::Pod')) {
1777	137				138	$pod = $current->content() . $pod;
1778	137				268	last; # Only take the immediately adjacent pod block
1779						} elsif ($current->isa('PPI::Token::Comment')) {
1780						# Include comments that might contain parameter info
1781	34				28	my $comment = $current->content();
1782	34	50			68	if ($comment =~ /#\s(?:param\|arg\|input)\s+\$(\w+)\s:\s*(.+)/i) {
1783	0				0	$pod .= "=item \$$1\n$2\n\n";
1784						}
1785						} elsif ($current->isa('PPI::Token::Whitespace') \|\|
1786						$current->isa('PPI::Token::Separator')) {
1787						# Skip whitespace and separators
1788						} elsif ($current->isa('PPI::Statement::Include')) {
1789						# allow 'use strict', 'use warnings' between POD and sub
1790						} else {
1791						# Hit non-POD, non-whitespace - stop
1792	206				158	last;
1793						}
1794	528				549	$current = $current->previous_sibling();
1795						}
1796
1797	347				326	return $pod;
1798						}
1799
1800						# --------------------------------------------------
1801						# _analyze_method
1802						#
1803						# Purpose: Perform full multi-source analysis of
1804						# a single method and produce a complete
1805						# schema hashref, combining POD analysis,
1806						# code pattern detection, signature
1807						# analysis, validator schema extraction,
1808						# confidence scoring, relationship
1809						# detection, and modern Perl feature
1810						# extraction.
1811						#
1812						# Entry: $method - a method hashref as produced
1813						# by _find_methods, containing
1814						# at minimum: name, body, pod.
1815						#
1816						# Exit: Returns a schema hashref containing:
1817						# function, input, output, _confidence,
1818						# _analysis, _notes, and optionally:
1819						# new, accessor, relationships,
1820						# _yamltest_hints, _attributes,
1821						# _modern_features, _fields, _model,
1822						# _low_confidence.
1823						#
1824						# Side effects: Logs progress to stdout when verbose
1825						# is set. May carp or croak if
1826						# strict_pod is enabled and POD/code
1827						# disagreements are found.
1828						#
1829						# Notes: This is the central analysis entry
1830						# point â€” it orchestrates all other
1831						# analysis helpers and merges their
1832						# results. The non-invasive reasoning
1833						# layer (Model::Method, Analyzer::*)
1834						# runs after the main schema is built
1835						# and attaches metadata only.
1836						# --------------------------------------------------
1837						sub _analyze_method {
1838	332			332	300	my ($self, $method) = @_;
1839	332				337	my $code = $method->{body};
1840	332				286	my $pod = $method->{pod};
1841
1842						# Extract modern features
1843	332				548	my $attributes = $self->_extract_subroutine_attributes($code);
1844	332				518	my $postfix_derefs = $self->_analyze_postfix_dereferencing($code);
1845	332				458	my $fields = $self->_extract_field_declarations($code);
1846
1847						# If this method came from a class, use those field declarations
1848	332 1	50	67		429 2	if ($method->{fields} && keys %{$method->{fields}}) {
1849	1				2	$fields = $method->{fields};
1850						}
1851
1852						my $schema = {
1853						function => $method->{name},
1854	332				1074	_confidence => {
1855						'input' => {},
1856						'output' => {}
1857						},
1858						input => {},
1859						output => {},
1860						setup => undef,
1861						transforms => {},
1862						};
1863
1864						# Analyze different sources
1865	332				560	my $pod_params = $self->_analyze_pod($pod);
1866	332				528	my $code_params = $self->_analyze_code($code, $method);
1867
1868						# Validate POD/code agreement if strict mode is enabled.
1869						# Skip when there is no POD at all â€” strict_pod checks accuracy of
1870						# existing documentation, not whether every method is documented.
1871	332	100	67		510	if ($self->{strict_pod} && $pod) {
1872						my @validation_errors = $self->_validate_pod_code_agreement(
1873						$pod_params,
1874						$code_params,
1875						$method->{name},
1876						{
1877	12				50	ignore_self => 1,
1878						allow_renames => 1,
1879						}
1880						);
1881
1882	12	100			20	if (@validation_errors) {
1883	11				26	my $error_msg = "POD/Code disagreement in method '$method->{name}':\n " .
1884						join("\n ", @validation_errors);
1885
1886						# Add to schema for reference even if we croak
1887	11				20	$schema->{_pod_validation_errors} = \@validation_errors;
1888
1889						# Either croak immediately or log based on configuration
1890	11	100			34	if($self->{strict_pod} == $STRICT_POD_FATAL) {
1891	1				12	croak("[POD STRICT] $error_msg");
1892						} else { # 1 = warnings
1893	10				797	carp("[POD STRICT] $error_msg");
1894						# Continue with analysis, but mark as problematic
1895	10				728	$schema->{_pod_disagreement} = 1;
1896						}
1897						}
1898	11				22	$schema->{_strict_pod_level} = $self->{strict_pod};
1899						}
1900
1901	331				528	my $validator_params = $self->_extract_validator_schema($code);
1902
1903	331	100			354	if ($validator_params) {
1904	5				11	$schema->{input} = $validator_params->{input};
1905	5				9	$schema->{input_style} = 'hash';
1906	5				16	$schema->{_confidence}{input} = { 'factors' => [ 'Determined from validator' ], 'level' => 'high' };
1907						$schema->{_analysis}{confidence_factors}{input} = [
1908	5				11	'Input schema extracted from validator'
1909						];
1910						# =head4 Input spec overrides take highest priority â€” apply them on top of
1911						# the validator schema so authors can tune test constraints (optional,
1912						# memberof, matches) without altering the runtime validation call.
1913	5				10	for my $name (keys %$pod_params) {
1914	0	0			0	next unless $pod_params->{$name}{_from_input_spec};
1915	0				0	my $pod_p = $pod_params->{$name};
1916	0		0		0	$schema->{input}{$name} //= {};
1917	0	0			0	$schema->{input}{$name}{optional} = $pod_p->{optional} if defined $pod_p->{optional};
1918	0	0			0	$schema->{input}{$name}{memberof} = $pod_p->{memberof} if defined $pod_p->{memberof};
1919	0	0			0	$schema->{input}{$name}{matches} = $pod_p->{matches} if defined $pod_p->{matches};
1920	0	0			0	$schema->{input}{$name}{type} = $pod_p->{type} if defined $pod_p->{type};
1921	0	0			0	$schema->{input}{$name}{min} = $pod_p->{min} if defined $pod_p->{min};
1922	0	0			0	$schema->{input}{$name}{max} = $pod_p->{max} if defined $pod_p->{max};
1923						}
1924						} else {
1925						# Merge field declarations into code_params before merging analyses
1926	326	100			457	if (keys %$fields) {
1927	1				2	$self->_merge_field_declarations($code_params, $fields);
1928						}
1929
1930						# Merge analyses
1931	326				477	$schema->{input} = $self->_merge_parameter_analyses(
1932						$pod_params,
1933						$code_params,
1934						);
1935						}
1936
1937						# ----------------------------------------
1938						# Legacy Output Analysis (unchanged)
1939						# ----------------------------------------
1940
1941						$schema->{output} = $self->_analyze_output(
1942						$method->{pod},
1943						$method->{body},
1944						$method->{name}
1945	331				637	);
1946
1947
1948						# Detect accessor methods
1949	331				1046	$self->_detect_accessor_methods($method, $schema);
1950
1951						# Detect if this is an instance method that needs object instantiation
1952						# Constructors never require object instantiation
1953	331				633	my $needs_object = $self->_needs_object_instantiation($method->{name}, $method->{body}, $method);
1954	331	100	100		690	if($method->{name} ne 'new' && $needs_object) {
1955	157				269	$schema->{new} = $needs_object;
1956	157				267	$self->_log(" NEW: Method requires object instantiation: $needs_object");
1957						}
1958
1959						# Calculate confidences
1960	331				363	my $input_confidence = $schema->{_confidence}{'input'};
1961	331	50			393	if(!ref($input_confidence)) {
1962	0				0	$input_confidence = $schema->{_confidence}{'input'} = $self->_calculate_input_confidence($schema->{input});
1963						}
1964	331				587	my $output_confidence = $schema->{_confidence}{'output'} = $self->_calculate_output_confidence($schema->{output});
1965
1966						# Add metadata
1967	331				615	$schema->{_notes} = $self->_generate_notes($schema->{input});
1968
1969						# Add analytics
1970	331		100		791	$schema->{_analysis} \|\|= {};
1971	331				448	$schema->{_analysis}{input_confidence} = $input_confidence->{level};
1972	331				363	$schema->{_analysis}{output_confidence} = $output_confidence->{level};
1973	331		100		666	$schema->{_analysis}{confidence_factors} \|\|= {};
1974	331		100		734	$schema->{_analysis}{confidence_factors}{input} \|\|= $input_confidence->{factors};
1975	331		33		668	$schema->{_analysis}{confidence_factors}{output} \|\|= $output_confidence->{factors};
1976
1977	331				309	foreach my $mode('input', 'output') {
1978	662				701	$self->_set_defaults($schema, $mode);
1979						}
1980
1981						# Optionally store detailed per-parameter analysis
1982	331	50			396	if ($input_confidence->{per_parameter}) {
1983	0				0	$schema->{_analysis}{per_parameter_scores} = $input_confidence->{per_parameter};
1984						}
1985
1986						# Calculate overall confidence (for backward compatibility)
1987	331				284	my $input_level = $input_confidence->{level};
1988	331				269	my $output_level = $output_confidence->{level};
1989
1990	331				743	my %level_rank = (
1991						none => 0,
1992						very_low => 1,
1993						low => 2,
1994						medium => 3,
1995						high => 4
1996						);
1997
1998						# Overall is the lower of input and output
1999	331		100		592	$input_level //= 'none';
2000	331		50		366	$output_level //= 'none';
2001	331	100			445	my $overall = $level_rank{$input_level} < $level_rank{$output_level} ? $input_level : $output_level;
2002
2003	331				359	$schema->{_analysis}{overall_confidence} = $overall;
2004
2005						# Analyze parameter relationships
2006	331				419	my $relationships = $self->_analyze_relationships($method);
2007	331 331	100	67		447 398	if ($relationships && @{$relationships}) {
2008	7				7	$schema->{relationships} = $relationships;
2009	7				15	$self->_log(" Found " . scalar(@$relationships) . " parameter relationships");
2010						}
2011
2012						# Store modern feature info in schema
2013	331	100			428	$schema->{_attributes} = $attributes if keys %$attributes;
2014	331	100			382	$schema->{_modern_features}{postfix_dereferencing} = $postfix_derefs if keys %$postfix_derefs;
2015	331	100			312	$schema->{_fields} = $fields if keys %$fields;
2016
2017						# Store class info if this is a class method
2018	331	100			414	if ($method->{class}) {
2019	1				1	$schema->{_class} = $method->{class};
2020						}
2021
2022	331				488	my $hints = $self->_extract_test_hints($method, $schema);
2023	331				491	$self->_extract_pod_examples($pod, $hints);
2024
2025	331				336	for my $k (qw(boundary_values invalid_inputs valid_inputs equivalence_classes)) {
2026	1324				824	my %seen;
2027						$hints->{$k} = [
2028	70	50			147	grep { !$seen{ defined $_ ? $_ : '__undef__' }++ }
2029	1324 1324				835 1569	@{ $hints->{$k} }
2030						];
2031						}
2032
2033						# --------------------------------------------------
2034						# YAML test hints: numeric boundaries
2035						# --------------------------------------------------
2036	331	100			421	if ($self->_method_has_numeric_intent($schema)) {
2037	155		50		316	$schema->{_yamltest_hints} \|\|= {};
2038
2039						# Do not override existing hints
2040	155		50		309	$schema->{_yamltest_hints}{boundary_values} \|\|= [];
2041
2042	0	0			0	my %seen = map { (defined $_ ? $_ : '__undef__') => 1 }
2043	155 155				122 198	@{ $schema->{_yamltest_hints}{boundary_values} };
2044
2045	155 155				116 201	foreach my $v (@{ $self->_numeric_boundary_values }) {
2046	774	100			565	my $key = defined $v ? $v : '__undef__';
2047	774 774	50			843 665	push @{ $schema->{_yamltest_hints}{boundary_values} }, $v unless $seen{$key}++;
2048						}
2049
2050	155				194	$self->_log(' HINTS: Added numeric boundary values');
2051						}
2052
2053	331	50			398	if (keys %$hints) {
2054	331		100		554	$schema->{_yamltest_hints} \|\|= {};
2055	331				359	foreach my $k (keys %$hints) {
2056						$schema->{_yamltest_hints}{$k} = $hints->{$k}
2057	1324	100			1397	unless exists $schema->{_yamltest_hints}{$k};
2058						}
2059						}
2060
2061	331	100	100		635	if(($level_rank{$overall} < $level_rank{$LEVEL_MEDIUM}) &&
2062						($level_rank{$overall} < ($self->{confidence_threshold} * 4))) {
2063	278				1201	$schema->{_low_confidence} = 1
2064						}
2065
2066						# ----------------------------------------
2067						# Non-invasive reasoning layer
2068						# ----------------------------------------
2069
2070						my $method_model = App::Test::Generator::Model::Method->new(
2071						name => $method->{name},
2072						source => $method->{body},
2073	331				1493	);
2074
2075	331				881	my $return_analyzer = App::Test::Generator::Analyzer::Return->new();
2076	331				545	$return_analyzer->analyze($method_model);
2077
2078						# Let model learn from finalized schema
2079	331	50			387	if ($schema->{output}) {
2080	331				522	$method_model->absorb_legacy_output($schema->{output});
2081						}
2082
2083	331				536	$method_model->resolve_return_type();
2084	331				510	$method_model->resolve_classification();
2085	331				448	$method_model->resolve_confidence();
2086
2087						# Attach only metadata
2088						$schema->{_model} = {
2089	331				485	classification => $method_model->classification,
2090						confidence => $method_model->confidence,
2091						};
2092
2093						# ----------------------------------------
2094						# Return Meta Analysis (Non-invasive)
2095						# ----------------------------------------
2096
2097	331				847	my $meta = App::Test::Generator::Analyzer::ReturnMeta->new();
2098	331				444	my $analysis = $meta->analyze($schema);
2099
2100	331				366	$schema->{_analysis}{stability_score} = $analysis->{stability_score};
2101	331				365	$schema->{_analysis}{consistency_score} = $analysis->{consistency_score};
2102	331				363	$schema->{_analysis}{risk_flags} = $analysis->{risk_flags};
2103
2104						# ----------------------------------------
2105						# Side Effect Analysis (Non-invasive)
2106						# ----------------------------------------
2107
2108	331				741	my $se = App::Test::Generator::Analyzer::SideEffect->new();
2109
2110	331				438	my $effects = $se->analyze($method);
2111
2112	331				332	$schema->{_analysis}{side_effects} = $effects;
2113
2114						# ----------------------------------------
2115						# Complexity Analysis (Non-invasive)
2116						# ----------------------------------------
2117
2118	331				709	my $cx = App::Test::Generator::Analyzer::Complexity->new();
2119	331				437	my $complexity = $cx->analyze($method);
2120
2121	331				362	$schema->{_analysis}{complexity} = $complexity;
2122
2123	331				2091	return $schema;
2124						}
2125
2126						# --------------------------------------------------
2127						# _method_has_numeric_intent
2128						#
2129						# Purpose: Determine whether a method schema
2130						# has numeric intent â€” either a numeric
2131						# output type or at least one required
2132						# numeric input parameter â€” to decide
2133						# whether to add standard numeric
2134						# boundary hint values.
2135						#
2136						# Entry: $schema - schema hashref as built by
2137						# _analyze_method.
2138						#
2139						# Exit: Returns 1 if numeric intent is
2140						# detected, 0 otherwise.
2141						#
2142						# Side effects: None.
2143						# --------------------------------------------------
2144						sub _method_has_numeric_intent {
2145	335			335	331	my ($self, $schema) = @_;
2146
2147						# Numeric output
2148	335	100	75		1229	return 1 if ($schema->{output} && $schema->{output}{type} && $schema->{output}{type} =~ /^(number\|integer)$/);
2149
2150						# Numeric inputs
2151	197 197	100			156 333	foreach my $p (values %{ $schema->{input} \|\| {} }) {
2152	164	100			201	next if $p->{optional};
2153	62	100	67		211	return 1 if ($p->{type} && $p->{type} =~ /^(number\|integer)$/);
2154						}
2155
2156	177				226	return 0;
2157						}
2158
2159						# --------------------------------------------------
2160						# _numeric_boundary_values
2161						#
2162						# Purpose: Return the standard set of numeric
2163						# boundary values used as test hints
2164						# for methods with numeric intent.
2165						#
2166						# Entry: None.
2167						#
2168						# Exit: Returns an arrayref of boundary
2169						# values: [-1, 0, 1, 2, 100].
2170						#
2171						# Side effects: None.
2172						# --------------------------------------------------
2173						sub _numeric_boundary_values {
2174	155			155	202	return [ -1, 0, 1, 2, 100 ];
2175						}
2176
2177						# --------------------------------------------------
2178						# _detect_accessor_methods
2179						#
2180						# Purpose: Detect whether a method is a getter,
2181						# setter, or combined getter/setter
2182						# accessor by analysing assignment and
2183						# return patterns involving $self->{...}.
2184						#
2185						# Entry: $method - method hashref containing
2186						# at minimum 'body' and
2187						# optionally 'pod'.
2188						# $schema - schema hashref (modified
2189						# in place).
2190						#
2191						# Exit: Returns nothing. Modifies $schema in
2192						# place, setting accessor, input,
2193						# input_style, output, and _confidence
2194						# keys as appropriate.
2195						#
2196						# Side effects: Croaks if a getter/setter has more
2197						# than one argument, or if a setter
2198						# returns non-self data.
2199						# Logs detections to stdout when
2200						# verbose is set.
2201						#
2202						# Notes: Four accessor patterns are detected
2203						# in order: (1) combined getter/setter
2204						# with shift, (2) combined getter/setter
2205						# with validated input, (3) getter only,
2206						# (4) setter that returns $self. Methods
2207						# accessing multiple $self fields are
2208						# skipped immediately.
2209						# --------------------------------------------------
2210						sub _detect_accessor_methods {
2211	336			336	353	my ($self, $method, $schema) = @_;
2212
2213	336				312	my $body = $method->{body};
2214
2215						# Normalize whitespace for regex sanity
2216	336				337	my $code = $body;
2217	336				1889	$code =~ s/\s+/ /g;
2218
2219						# If a method touches more than one $self->{...}, itâ€™s not an accessor.
2220	336				290	my %fields_seen;
2221	336				623	while ($code =~ /\$self\s->\s\{\s['"]?([^}'"]+)['"]?\s\}/g) {
2222	93				165	$fields_seen{$1}++;
2223						}
2224	336	100			832	if (keys(%fields_seen) > 1) {
2225	4				7	$self->_log(" Skipping accessor detection: multiple fields accessed");
2226	4				5	return;
2227						}
2228
2229						# -------------------------------
2230						# Getter/Setter combo
2231						# -------------------------------
2232	332	50 100 100 100	50 75 100		1747	if (
2233						# Require get/set of the same property
2234						$code =~ /\$self\s->\s\{\s['"]?([^}'"]+)['"]?\s\}\s=\sshift\s*;/ &&
2235						$code =~ /return\s+\$self\s->\s\{\s['"]?\Q$1\E['"]?\s\}\s*;/ &&
2236						$code =~ /if\s\(\s\@_/
2237						) {
2238	0				0	my $property = $1;
2239
2240	0	0			0	if(!defined($property)) {
2241	0	0			0	if($code =~ /\$self\s->\s\{\s['"]?([^}'"]+)['"]?\s\}\s=\sshift\s*;/) {
2242	0				0	$property = $1;
2243						}
2244						}
2245
2246						$schema->{accessor} = {
2247	0				0	type => 'getset',
2248						property => $property,
2249						};
2250
2251	0				0	$self->_log(" Detected getter/setter accessor for property: $property");
2252
2253	0		0		0	$schema->{input} \|\|= { value => { type => 'string', optional => 1 } };
2254
2255	0				0	$schema->{input_style} = 'hash';
2256
2257						$schema->{_confidence}{input} = {
2258	0				0	level => 'high',
2259						factors => ['Detected combined getter/setter accessor'],
2260						};
2261	0	0			0	if (my $pod = $method->{pod}) {
2262	0	0			0	if ($pod =~ /\b(LWP::UserAgent(?:::\w+)*)\b/) {
2263	0				0	my $class = $1;
2264						$schema->{output} = {
2265	0				0	type => 'object',
2266						isa => $class,
2267						};
2268	0				0	$schema->{input}{$property} = {
2269						type => 'object',
2270						isa => $class,
2271						optional => 1,
2272						};
2273
2274						$schema->{_confidence}{output} = {
2275	0				0	level => 'high',
2276						factors => ['POD specifies UserAgent object'],
2277						};
2278						}
2279						}
2280						} elsif($code =~ /if\s\(\s(?:\@_\|[\$]\w+)/ &&
2281						$code =~ /\$self\s->\s\{\s['"]?([^}'"]+)['"]?\s\}\s=\s(?:shift\|\@_\|\$_\[\d+\]\|\$\w+)\b/x &&
2282						$code =~ /return\b/
2283						) {
2284						# -------------------------------
2285						# Getter/Setter (validated input)
2286						# -------------------------------
2287	7				7	my $property = $1;
2288
2289	7	50			9	if(!defined($property)) {
2290	7	50			20	if($code =~ /\$self\s->\s\{\s['"]?([^}'"]+)['"]?\s\}\s*=/) {
2291	7				9	$property = $1;
2292						}
2293						}
2294	7	100			11	if ($code =~ /validate_strict/) {
2295	2 2				2 4	push @{ $schema->{_confidence}{input}{factors} }, 'Setter uses Params::Validate::Strict';
2296						} else {
2297						# ---------------------------------------
2298						# Detect object input via blessed($arg)
2299						# ---------------------------------------
2300	5	50			8	if ($code =~ /blessed\s$\s\$(\w+)\s*$/) {
2301	0				0	my $param = $1;
2302
2303	0				0	$self->_log(" Detected object input via blessed(\$$param)");
2304
2305						$schema->{input} = {
2306	0				0	$param => {
2307						type => 'object',
2308						optional => 1,
2309						}
2310						};
2311
2312						$schema->{_confidence}{input} = {
2313	0				0	level => 'high',
2314						factors => ['Input validated by Scalar::Util::blessed'],
2315						};
2316						} else {
2317						# fallback ONLY if nothing known
2318						$schema->{input} \|\|= {
2319	5		50		8	value => { type => 'string', optional => 1 },
2320						};
2321						}
2322						};
2323						$schema->{accessor} = {
2324	7				15	type => 'getset',
2325						property => $property,
2326						};
2327
2328	7				13	$self->_log(" Detected getter/setter accessor for property: $property");
2329	7	100			10	if (my $pod = $method->{pod}) {
2330	2	50			6	if ($pod =~ /\b(LWP::UserAgent(?:::\w+)*)\b/) {
2331	0				0	my $class = $1;
2332						$schema->{output} = {
2333	0				0	type => 'object',
2334						isa => $class,
2335						};
2336	0				0	$schema->{input}{$property} = {
2337						type => 'object',
2338						isa => $class,
2339						optional => 1,
2340						};
2341
2342						$schema->{_confidence}{output} = {
2343	0				0	level => 'high',
2344						factors => ['POD specifies UserAgent object'],
2345						};
2346						}
2347						}
2348						# Set position 0 on whichever single input parameter already exists.
2349						# The parameter may be named differently from the stored property
2350						# (e.g. $dir for the logdir property), so find the existing key
2351						# rather than creating a new entry keyed by $property â€” doing the
2352						# latter produces a duplicate-position collision between the real
2353						# param and the spurious $property key.
2354	7	50			13	if(ref($schema->{input}) eq 'HASH') {
2355	7 7				8 9	my @input_keys = keys %{$schema->{input}};
2356	7	50 50			15	if(scalar @input_keys > 1) {
2357	0				0	croak(__PACKAGE__, ': A getset accessor function can have at most one argument');
2358						} elsif(@input_keys == 1) {
2359	7				16	$schema->{input}{$input_keys[0]}{position} = 0;
2360						} else {
2361	0				0	$schema->{input}{$property}{position} = 0;
2362						}
2363						}
2364						} elsif ($code =~ /return\s+\$self\s->\s\{\s['"]?([^}'"]+)['"]?\s\}\s*;/) {
2365						# -------------------------------
2366						# Getter
2367						# -------------------------------
2368	25				38	my $property = $1;
2369
2370						# Don't flag mutators like
2371						# sub foo {
2372						# my $self = shift;
2373						# $self->{bar} = shift;
2374						# return $self->{bar};
2375						# }
2376						# Only exclude if the property is being set FROM EXTERNAL INPUT
2377	25	100			1146	if($code !~ /\$self\s->\s\{\s['"]?\Q$property\E['"]?\s\}\s=\s(?:shift\|\$\w+\s=\sshift\|\@_\|\$_\[\d+\])/) {
2378	24				64	my @returns = $code =~ /return\b/g;
2379	24				366	my @self_returns = $code =~ /return\s+\$self\s->\s\{\s['"]?\Q$property\E['"]?\s\}/g;
2380						# it's a getter
2381	24	100			59	if (scalar(@returns) == scalar(@self_returns)) {
2382						# all returns are returning $self->{$property}, so it's a getter
2383						$schema->{accessor} = {
2384	22				58	type => 'getter',
2385						property => $property,
2386						};
2387
2388	22				48	$self->_log(" Detected getter accessor for property: $property");
2389
2390						$schema->{_confidence}{output} = {
2391	22				100	level => 'high',
2392						factors => ['Detected getter method'],
2393						};
2394	22				45	delete $schema->{input};
2395						}
2396						}
2397						} elsif (
2398						$code =~ /return\s+\$self\b/ &&
2399						$code =~ /\$self\s->\s\{\s['"]?([^}'"]+)['"]?\s\}\s=\s\$(\w+)\s*;/
2400						) {
2401						# -------------------------------
2402						# Setter
2403						# -------------------------------
2404	6				15	my ($property, $param) = ($1, $2);
2405
2406						$schema->{accessor} = {
2407	6				21	type => 'setter',
2408						property => $property,
2409						param => $param,
2410						};
2411
2412	6				12	$self->_log(" Detected setter accessor for property: $property");
2413
2414						$schema->{input} = {
2415	6				16	$param => { type => 'string' }, # safe default
2416						};
2417	6				10	$schema->{input_style} = 'hash';
2418
2419						$schema->{_confidence}{input} = {
2420	6				14	level => 'high',
2421						factors => ['Detected setter/accessor method'],
2422						};
2423	6	100 50			11	if($schema->{output}{_returns_self}) {
2424	5	50			10	if($schema->{output}{type} ne 'object') {
2425	0				0	croak 'Setter can not return data other than $self';
2426						}
2427	5	50			9	if($schema->{output}{isa} ne $self->{_package_name}) {
2428	0				0	croak 'Setter can not return data other than $self';
2429						}
2430	1				3	} elsif(scalar(keys %{$schema->{output}}) != 0) {
2431						$self->_analysis_error(
2432						method => $method->{name},
2433	0				0	message => "Setter cannot return data",
2434						);
2435						}
2436						}
2437
2438	332	100			503	if(exists($schema->{accessor})) {
2439	35	50	50		177	if($schema->{accessor}{type} && $schema->{accessor}{type} =~ /setter\|getset/ && $schema->{input}) {
2440	13 13				10 21	for my $param (keys %{ $schema->{input} }) {
2441	13				15	my $in = $schema->{input}{$param};
2442
2443	13	100	100		33	if ($in->{type} && ($in->{type} eq 'object')) {
2444						$schema->{output} = {
2445						type => 'object',
2446	2	50			5	($in->{isa} ? (isa => $in->{isa}) : ()),
2447						};
2448
2449						$schema->{_confidence}{output} = {
2450	2				4	level => 'high',
2451						factors => ['Output type propagated from setter input'],
2452						};
2453						}
2454						}
2455						}
2456
2457	35	100	67		253	if($schema->{accessor}{type} && $schema->{accessor}{property} && ($schema->{accessor}{type} =~ /getter\|getset/) &&
2458						((!defined($schema->{output}{type})) \|\| ($schema->{output}{type} eq 'string'))) {
2459	26	100			51	if (my $pod = $method->{pod}) {
2460						# POD says "UserAgent object"
2461	12	100			39	if ($pod =~ /\bUser[- ]?Agent\b.*\bobject\b/i) {
2462	1				1	$schema->{output}{type} = 'object';
2463	1				2	$schema->{output}{isa} = 'LWP::UserAgent';
2464
2465	1 1				1 2	push @{ $schema->{_confidence}{output}{factors} }, 'POD indicates UserAgent object';
2466
2467	1				2	$schema->{_confidence}{output}{level} = 'high';
2468						}
2469						}
2470						}
2471						}
2472						}
2473
2474						# --------------------------------------------------
2475						# _analysis_error
2476						#
2477						# Purpose: Report a fatal analysis error with
2478						# module, method, and file context,
2479						# then croak.
2480						#
2481						# Entry: Named args:
2482						# method - method name string.
2483						# message - error description string.
2484						#
2485						# Exit: Does not return â€” always croaks.
2486						#
2487						# Side effects: None beyond the croak.
2488						# --------------------------------------------------
2489						sub _analysis_error {
2490	2			2	3459	my ($self, %args) = @_;
2491
2492	2		100		10	my $method = $args{method} // 'UNKNOWN';
2493	2		100		6	my $msg = $args{message} // 'Analysis error';
2494
2495	2		100		8	my $module = $self->{_package_name} // 'UNKNOWN';
2496	2		100		7	my $file = $self->{input_file} // 'UNKNOWN';
2497
2498	2				19	croak join "\n",
2499						$msg,
2500						" Module: $module",
2501						" Method: $method",
2502						" File: $file",
2503						'';
2504						}
2505
2506						# --------------------------------------------------
2507						# _extract_validator_schema
2508						#
2509						# Purpose: Try each supported validator extractor
2510						# in priority order and return the first
2511						# schema that yields a non-empty input
2512						# spec. Used to detect explicit
2513						# parameter validation declarations
2514						# before falling back to heuristic
2515						# code analysis.
2516						#
2517						# Entry: $code - method body source string.
2518						#
2519						# Exit: Returns a schema hashref on success,
2520						# or undef if no supported validator
2521						# call is detected.
2522						#
2523						# Side effects: None.
2524						#
2525						# Notes: Extractors tried in order:
2526						# Params::Validate::Strict,
2527						# Params::Validate,
2528						# MooseX::Params::Validate,
2529						# Type::Params.
2530						# --------------------------------------------------
2531						sub _extract_validator_schema {
2532	336			336	345	my ($self, $code) = @_;
2533
2534	336				382	for my $extractor ('_extract_pvs_schema', '_extract_pv_schema', '_extract_moosex_params_schema', '_extract_type_params_schema') {
2535	1329				1919	my $res = $self->$extractor($code);
2536	1329 7	50 50	50		3900 24	return $res if ($res && ref($res) eq 'HASH' && keys %{ $res->{input} \|\| {} });
2537						}
2538
2539	329				322	return;
2540						}
2541
2542						# --------------------------------------------------
2543						# _parse_schema_hash
2544						#
2545						# Purpose: Parse a PPI block node representing
2546						# a validator schema hash literal and
2547						# return a normalised schema structure
2548						# suitable for use as input spec.
2549						#
2550						# Entry: $hash - a PPI node with a children()
2551						# method, typically a
2552						# PPI::Structure::Block from
2553						# a validate_strict call.
2554						#
2555						# Exit: Returns a hashref with keys:
2556						# input - hashref of param specs
2557						# input_style - 'hash'
2558						# _confidence - confidence hashref
2559						# or undef if parsing fails.
2560						#
2561						# Side effects: None.
2562						# --------------------------------------------------
2563						sub _parse_schema_hash {
2564	1			1	866	my ($self, $hash) = @_;
2565
2566	1				1	my %result;
2567
2568	1				4	for my $child ($hash->children) {
2569						# skip whitespace and operators
2570	1	50	33		9	if ($child->isa('PPI::Statement') \|\| $child->isa('PPI::Statement::Expression')) {
2571	0				0	my ($key, $val);
2572
2573						my @tokens = grep {
2574	0 0		0		0 0	!$_->isa('PPI::Token::Whitespace') &&
2575						!$_->isa('PPI::Token::Operator')
2576						} $child->children;
2577
2578	0				0	for (my $i = 0; $i < @tokens - 1; $i++) {
2579	0	0	0		0	if(($tokens[$i]->isa('PPI::Token::Word') \|\| $tokens[$i]->isa('PPI::Token::Quote')) &&
2580						$tokens[$i+1]->isa('PPI::Structure::Constructor')) {
2581	0				0	$key = $tokens[$i]->content;
2582	0				0	$key =~ s/^['"]\|['"]$//g;
2583	0				0	$val = $tokens[$i+1];
2584	0				0	last;
2585						}
2586						}
2587
2588	0	0	0		0	next unless $key && $val;
2589
2590	0				0	my %param;
2591	0				0	for my $inner ($val->children) {
2592	0	0	0		0	next unless $inner->isa('PPI::Statement') \|\| $inner->isa('PPI::Statement::Expression');
2593
2594						my ($k, undef, $v) = grep {
2595	0 0		0		0 0	!$_->isa('PPI::Token::Whitespace') &&
2596						!$_->isa('PPI::Token::Operator')
2597						} $inner->children;
2598
2599	0	0	0		0	next unless $k && $v;
2600
2601	0				0	my $keyname = $k->content;
2602	0	0			0	my $value = $v->can('content') ? $v->content : undef;
2603	0	0			0	$value =~ s/^['"]\|['"]$//g if defined $value;
2604
2605	0	0 0 0 0	0		0	if ($keyname eq 'type') {
2606	0				0	$param{type} = lc($value);
2607						} elsif ($keyname eq 'optional') {
2608	0	0			0	$param{optional} = $value ? 1 : 0;
2609						} elsif ($keyname =~ /^(min\|max)$/ && looks_like_number($value)) {
2610	0				0	$param{$keyname} = 0 + $value;
2611						} elsif ($keyname eq 'matches') {
2612	0				0	$param{matches} = qr/$value/;
2613						}
2614						}
2615
2616	0		0		0	$param{type} //= 'string';
2617	0		0		0	$param{optional} //= 0;
2618
2619	0				0	$result{$key} = \%param;
2620						}
2621						}
2622
2623						return {
2624	1				5	input => \%result,
2625						input_style => 'hash',
2626						_confidence => {
2627						input => {
2628						level => 'high',
2629						factors => ['Input schema extracted from validator'],
2630						},
2631						},
2632						};
2633						}
2634
2635						# --------------------------------------------------
2636						# _ppi
2637						#
2638						# Purpose: Return a PPI::Document for a code
2639						# string, using a per-instance cache
2640						# to avoid re-parsing the same string
2641						# multiple times during a single
2642						# analysis pass.
2643						#
2644						# Entry: $code - either a string of Perl source
2645						# code, or an object that
2646						# already has a find() method
2647						# (returned as-is).
2648						#
2649						# Exit: Returns a PPI::Document, or the
2650						# original object if it already
2651						# supports find().
2652						#
2653						# Side effects: Populates $self->{_ppi_cache}.
2654						# --------------------------------------------------
2655						sub _ppi {
2656	29			29	5594	my ($self, $code) = @_;
2657
2658	29	100	67		51	return $code if ref($code) && $code->can('find');
2659
2660	28		100		81	$self->{_ppi_cache} \|\|= {};
2661	28		67		135	return $self->{_ppi_cache}{$code} //= PPI::Document->new(\$code);
2662						}
2663
2664						# --------------------------------------------------
2665						# _extract_pvs_schema
2666						#
2667						# Purpose: Detect and extract a parameter schema
2668						# from a Params::Validate::Strict
2669						# validate_strict() call in the method
2670						# body.
2671						#
2672						# Entry: $code - method body source string.
2673						#
2674						# Exit: Returns a schema hashref with input,
2675						# style, and source keys on success,
2676						# or undef if no validate_strict call
2677						# is found or parsing fails.
2678						#
2679						# Side effects: None.
2680						# --------------------------------------------------
2681						sub _extract_pvs_schema {
2682	344			344	332	my ($self, $code) = @_;
2683
2684	344	100			607	return unless $code =~ /\bvalidate_strict\s*\(/;
2685
2686	9	50			16	my $doc = $self->_ppi($code) or return;
2687
2688						my $calls = $doc->find(sub {
2689	954	100	100	954	4533	$_[1]->isa('PPI::Token::Word') && ($_[1]->content eq 'validate_strict' \|\| $_[1]->content eq 'Params::Validate::Strict::validate_strict')
2690	9	50			45764	}) or return;
2691
2692	9				71	for my $call (@$calls) {
2693	9				26	my $list = $call->parent();
2694	9		67		164	while ($list && !$list->isa('PPI::Structure::List')) {
2695	40				242	$list = $list->parent();
2696						}
2697	9	50			27	if(!defined($list)) {
2698	9				22	my $next = $call->next_sibling();
2699	9	50			222	next unless defined $next;
2700	9	100			13	if($next->content() =~ /schema\s=>\s(\{(?:[^{}]\|\{(?:[^{}]\|\{[^{}]\})\})*\})/s) {
2701	7				1009	my $schema_text = $1;
2702	7	50			22	next if $schema_text =~ $UNSAFE_KEYWORD_RE;
2703	7				67	my $compartment = Safe->new();
2704	7				3062	$compartment->permit_only(qw(:base_core :base_mem :base_orig));
2705
2706	7				30	my $schema_str = "my \$schema = $schema_text";
2707	7				16	my $schema = $compartment->reval($schema_str);
2708	7 7	50			2139 15	if(scalar keys %{$schema}) {
2709						return {
2710	7				24	input => $schema,
2711						style => 'hash',
2712						source => 'validator'
2713						}
2714						}
2715						}
2716						}
2717	2	50			110	next unless $list;
2718
2719	0 0				0 0	my ($schema_block) = grep { $_->isa('PPI::Structure::Block') } $list->children;
2720
2721	0	0			0	next unless $schema_block;
2722
2723	0				0	my $schema = $self->_extract_schema_hash_from_block($schema_block);
2724	0	0			0	return $self->_normalize_validator_schema($schema) if $schema;
2725						}
2726
2727	2				3	return;
2728						}
2729
2730						# --------------------------------------------------
2731						# _extract_pv_schema
2732						#
2733						# Purpose: Detect and extract a parameter schema
2734						# from a Params::Validate validate()
2735						# call in the method body.
2736						#
2737						# Entry: $code - method body source string.
2738						#
2739						# Exit: Returns a schema hashref with input,
2740						# style, and source keys on success,
2741						# or undef if no validate() call is
2742						# found or parsing fails.
2743						#
2744						# Side effects: None.
2745						# --------------------------------------------------
2746						sub _extract_pv_schema {
2747	342			342	352	my ($self, $code) = @_;
2748
2749	342	100			552	return unless $code =~ /\bvalidate\s*\(/;
2750
2751	8	50			13	my $doc = $self->_ppi($code) or return;
2752
2753						my $calls = $doc->find(sub {
2754	689	100	100	689	3278	$_[1]->isa('PPI::Token::Word') && ($_[1]->content eq 'validate' \|\| $_[1]->content eq 'Params::Validate::validate')
2755	8	50			32610	}) or return;
2756
2757	8				54	for my $call (@$calls) {
2758	8				19	my $list = $call->parent;
2759	8		67		140	while ($list && !$list->isa('PPI::Structure::List')) {
2760	30				168	$list = $list->parent;
2761						}
2762	8	50			20	if(!defined($list)) {
2763	8				14	my $next = $call->next_sibling();
2764	8				213	my ($arglist, $schema_text) = $self->_parse_pv_call($next);
2765
2766	8	50	33		30	if($schema_text && $schema_text !~ $UNSAFE_KEYWORD_RE) {
2767	8				64	my $compartment = Safe->new();
2768	8				3301	$compartment->permit_only(qw(:base_core :base_mem :base_orig));
2769
2770	8				33	my $schema_str = "my \$schema = $schema_text";
2771	8				12	my $schema = $compartment->reval($schema_str);
2772
2773	8 8	100			2232 16	if(scalar keys %{$schema}) {
2774	7 7				11 7	foreach my $arg(keys %{$schema}) {
2775	12				9	my $field = $schema->{$arg};
2776	12	50			37	if(my $type = $field->{'type'}) {
2777	12	100 50			19	if($type eq 'ARRAYREF') {
2778	1				1	$field->{'type'} = 'arrayref';
2779						} elsif($type eq 'SCALAR') {
2780	11				11	$field->{'type'} = 'string';
2781						}
2782						}
2783	12				26	delete $field->{'callbacks'};
2784						}
2785
2786						return {
2787	7				29	input => $schema,
2788						style => 'hash',
2789						source => 'validator'
2790						}
2791						}
2792						}
2793						}
2794	1	50			43	next unless $list;
2795
2796	0 0				0 0	my ($schema_block) = grep { $_->isa('PPI::Structure::Block') } $list->children;
2797
2798	0	0			0	next unless $schema_block;
2799
2800	0				0	my $schema = $self->_extract_schema_hash_from_block($schema_block);
2801	0	0			0	return $self->_normalize_validator_schema($schema) if $schema;
2802						}
2803
2804	1				1	return;
2805						}
2806
2807						# --------------------------------------------------
2808						# _parse_pv_call
2809						#
2810						# Purpose: Split a Params::Validate call argument
2811						# string into its two components: the
2812						# first argument (typically \@_) and
2813						# the schema hash string.
2814						#
2815						# Entry: $string - the raw argument string
2816						# from the validate() call,
2817						# including outer parentheses.
2818						#
2819						# Exit: Returns a two-element list:
2820						# ($first_arg, $hash_str)
2821						# or an empty list if no comma is found
2822						# at brace depth zero (malformed call).
2823						#
2824						# Side effects: None.
2825						# --------------------------------------------------
2826						sub _parse_pv_call {
2827	21			21	35	my ($self, $string) = @_;
2828
2829						# Remove outer parentheses and whitespace
2830	21				33	$string =~ s/^\s\(\s//;
2831	21				2736	$string =~ s/\s\)\s$//;
2832
2833						# Find the first comma at brace-depth 0, jumping over each balanced
2834						# {...} block in one step via extract_bracketed rather than
2835						# counting depth character by character
2836	21				907	require Text::Balanced;
2837	21				8610	my $rest = $string;
2838	21				23	my $comma_pos = 0;
2839	21				19	my $found_comma = 0;
2840
2841	21				30	while (length $rest) {
2842	93	100			91	if (substr($rest, 0, 1) eq '{') {
2843						# extract_bracketed advances $rest past the extracted block
2844						# in place, so $rest must not be re-truncated afterwards
2845	1				4	my $extracted = Text::Balanced::extract_bracketed($rest, '{}');
2846	1	50			141	return unless defined $extracted; # Broken source code
2847	1				1	$comma_pos += length $extracted;
2848	1				2	next;
2849						}
2850	92	100			79	if (substr($rest, 0, 1) eq ',') {
2851	20				16	$found_comma = 1;
2852	20				15	last;
2853						}
2854	72				45	$comma_pos++;
2855	72				67	$rest = substr($rest, 1);
2856						}
2857
2858	21	100			26	return unless $found_comma;
2859
2860	20				19	my $first_arg = substr($string, 0, $comma_pos);
2861	20				26	my $hash_str = substr($string, $comma_pos + 1);
2862
2863						# Trim whitespace
2864	20				40	$first_arg =~ s/^\s+\|\s+$//g;
2865	20				161	$hash_str =~ s/^\s+\|\s+$//g;
2866
2867	20				31	return ($first_arg, $hash_str);
2868						}
2869
2870						# --------------------------------------------------
2871						# _extract_moosex_params_schema
2872						#
2873						# Purpose: Detect and extract a parameter schema
2874						# from a MooseX::Params::Validate
2875						# validated_hash() call in the method
2876						# body.
2877						#
2878						# Entry: $code - method body source string.
2879						#
2880						# Exit: Returns a schema hashref with input,
2881						# style, and source keys on success,
2882						# or undef if no validated_hash() call
2883						# is found or parsing fails.
2884						#
2885						# Side effects: None.
2886						# --------------------------------------------------
2887						sub _extract_moosex_params_schema
2888						{
2889	341			341	392	my ($self, $code) = @_;
2890
2891	341	100			506	return unless $code =~ /\bvalidated_hash\s*\(/;
2892
2893	9	50			11	my $doc = $self->_ppi($code) or return;
2894
2895						my $calls = $doc->find(sub {
2896	742	100		742	3372	$_[1]->isa('PPI::Token::Word') && ($_[1]->content eq 'validated_hash')
2897	9	50			33819	}) or return;
2898
2899	9				61	for my $call (@$calls) {
2900	9				22	my $list = $call->parent();
2901	9		67		212	while ($list && !$list->isa('PPI::Structure::List')) {
2902	36				233	$list = $list->parent;
2903						}
2904	9	50			22	if(!defined($list)) {
2905	9				16	my $next = $call->next_sibling();
2906	9				264	my ($arglist, $schema_text) = $self->_parse_pv_call($next);
2907
2908	9	50	33		29	if($schema_text && $schema_text !~ $UNSAFE_KEYWORD_RE) {
2909	9				73	my $compartment = Safe->new();
2910	9				3723	$compartment->permit_only(qw(:base_core :base_mem :base_orig));
2911
2912	9				37	my $schema_str = "my \$schema = { $schema_text }";
2913	9				21	$schema_str =~ s/ArrayRef\[(.+?)\]/arrayref, element_type => $1/g;
2914	9				15	my $schema = $compartment->reval($schema_str);
2915
2916	9 9	50			2556 15	if(scalar keys %{$schema}) {
2917	9 9				7 10	foreach my $arg(keys %{$schema}) {
2918	14				12	my $field = $schema->{$arg};
2919	14	50			19	if(my $isa = delete $field->{'isa'}) {
2920	14				20	$field->{'type'} = $isa;
2921						}
2922	14	100			18	if(exists($field->{'required'})) {
2923	11				11	my $required = delete $field->{'required'};
2924	11	100			15	$field->{'optional'} = $required ? 0 : 1;
2925						} else {
2926	3				4	$field->{'optional'} = 1;
2927						}
2928	14	100			21	if(ref($field->{'default'}) eq 'CODE') {
2929	2				27	delete $field->{'default'}; # TODO
2930						}
2931						}
2932
2933	9 9				8 10	foreach my $arg(keys %{$schema}) {
2934	14				11	my $field = $schema->{$arg};
2935	14	50			14	if(my $type = $field->{'type'}) {
2936	14	50 50			16	if($type eq 'ARRAYREF') {
2937	0				0	$field->{'type'} = 'arrayref';
2938						} elsif($type eq 'SCALAR') {
2939	0				0	$field->{'type'} = 'string';
2940						}
2941						}
2942	14				12	delete $field->{'callbacks'};
2943						}
2944
2945						return {
2946	9				31	input => $schema,
2947						style => 'hash',
2948						source => 'validator'
2949						}
2950						}
2951						}
2952						}
2953	0	0			0	next unless $list;
2954
2955	0 0				0 0	my ($schema_block) = grep { $_->isa('PPI::Structure::Block') } $list->children;
2956
2957	0	0			0	next unless $schema_block;
2958
2959	0				0	my $schema = $self->_extract_schema_hash_from_block($schema_block);
2960	0	0			0	return $self->_normalize_validator_schema($schema) if $schema;
2961						}
2962
2963	0				0	return;
2964						}
2965
2966						# --------------------------------------------------
2967						# _extract_schema_hash_from_block
2968						#
2969						# Purpose: Extract a parameter schema hashref from
2970						# a PPI::Structure::Block node representing
2971						# the schema argument to a validator call
2972						# such as validate_strict({ ... }).
2973						#
2974						# Entry: $block - a PPI::Structure::Block node.
2975						#
2976						# Exit: Returns a hashref of parameter name to
2977						# spec hashref, or undef if parsing fails.
2978						#
2979						# Side effects: None.
2980						#
2981						# Notes: Delegates to _parse_schema_hash which
2982						# expects a PPI node with a children()
2983						# method. This method exists to provide
2984						# a clear semantic name at the call site.
2985						# --------------------------------------------------
2986						sub _extract_schema_hash_from_block {
2987	2			2	6	my ($self, $block) = @_;
2988
2989	2	50	67		11	return unless $block && $block->can('children');
2990
2991	0				0	my $result = $self->_parse_schema_hash($block);
2992
2993	0	0	0		0	return unless $result && ref($result) eq 'HASH' && $result->{input};
2994
2995	0				0	return $result->{input};
2996						}
2997
2998						# --------------------------------------------------
2999						# _normalize_validator_schema
3000						#
3001						# Purpose: Normalise a raw validator schema
3002						# hashref (as extracted from PPI) into
3003						# the standard input spec format used
3004						# throughout the extractor.
3005						#
3006						# Entry: $schema - hashref of parameter name
3007						# to raw spec hashref, as
3008						# produced by
3009						# _extract_schema_hash_from_block.
3010						#
3011						# Exit: Returns a hashref with keys:
3012						# input_style - 'hash'
3013						# input - normalised param specs
3014						# Each param spec gains an explicit
3015						# optional key and _source / _type_confidence
3016						# metadata.
3017						#
3018						# Side effects: None.
3019						# --------------------------------------------------
3020						sub _normalize_validator_schema {
3021	5			5	20	my ($self, $schema) = @_;
3022
3023	5				5	my %input;
3024
3025	5				6	for my $name (keys %$schema) {
3026	8				8	my $spec = $schema->{$name};
3027
3028						$input{$name} = {
3029						%$spec,
3030	8	100			21	optional => exists $spec->{optional} ? $spec->{optional} : 0,
3031						_source => 'validator',
3032						_type_confidence => 'high',
3033						};
3034						}
3035
3036						return {
3037	5				7	input_style => 'hash',
3038						input => \%input,
3039						};
3040						}
3041
3042						# --------------------------------------------------
3043						# _extract_type_params_schema
3044						#
3045						# Purpose: Detect and extract a parameter schema
3046						# from a Type::Params signature_for()
3047						# declaration for the current method,
3048						# located in the module-level document.
3049						#
3050						# Entry: $code - method body source string
3051						# (used to extract the function
3052						# name for lookup).
3053						#
3054						# Exit: Returns a schema hashref on success,
3055						# or undef if no signature_for
3056						# declaration is found or compilation
3057						# fails.
3058						#
3059						# Side effects: May fork a child process to compile
3060						# the signature in isolation.
3061						# --------------------------------------------------
3062						sub _extract_type_params_schema {
3063	332			332	4290	my ($self, $code) = @_;
3064
3065	332	100			455	my $function = $self->_extract_function_name($code) or return;
3066
3067	331	100			764	my $doc = $self->{_document} or return;
3068	328	100			429	my $stmt = $self->_find_signature_statement($doc, $function) or return;
3069
3070	2	50			8	my $signature_expr = $self->_extract_signature_expression($stmt, $function) or return;
3071
3072	2	100			8	my $meta = $self->_compile_signature_isolated($function, $signature_expr) or return;
3073
3074	1				3	return $self->_build_schema_from_meta($meta);
3075						}
3076
3077						# --------------------------------------------------
3078						# _extract_function_name
3079						#
3080						# Purpose: Extract the subroutine name from the
3081						# start of a method body string, used
3082						# to look up its Type::Params signature.
3083						#
3084						# Entry: $code - method body source string.
3085						#
3086						# Exit: Returns the subroutine name string,
3087						# or undef if no 'sub name' declaration
3088						# is found.
3089						#
3090						# Side effects: None.
3091						# --------------------------------------------------
3092						sub _extract_function_name {
3093	333			333	1376	my ($self, $code) = @_;
3094	333	100			1197	return $1 if $code =~ /^\s*sub\s+([a-zA-Z0-9_]+)/;
3095	3				5	return;
3096						}
3097
3098						# --------------------------------------------------
3099						# _find_signature_statement
3100						#
3101						# Purpose: Search a PPI document for a
3102						# signature_for statement that
3103						# corresponds to a named function.
3104						#
3105						# Entry: $doc - PPI::Document to search.
3106						# $function - function name string.
3107						#
3108						# Exit: Returns the matching PPI::Statement
3109						# node, or undef if none is found.
3110						#
3111						# Side effects: None.
3112						# --------------------------------------------------
3113						sub _find_signature_statement {
3114	328			328	4368	my ($self, $doc, $function) = @_;
3115
3116						my $statements = $doc->find(
3117						sub {
3118	237476	100		237476	1502999	$_[1]->isa('PPI::Statement') && $_[1]->content =~ /^\s*signature_for\b/
3119						}
3120	328	100			872	) or return;
3121
3122	2				16	foreach my $stmt (@$statements) {
3123	2				3	my $content = $stmt->content;
3124	2	50			132	if ($content =~ /^\s*signature_for\s+\Q$function\E\b/) {
3125	2				6	return $stmt;
3126						}
3127						}
3128
3129	0				0	return;
3130						}
3131
3132						# --------------------------------------------------
3133						# _extract_signature_expression
3134						#
3135						# Purpose: Extract the Type::Params signature
3136						# expression (everything after =>) from
3137						# a signature_for statement node.
3138						#
3139						# Entry: $stmt - PPI::Statement node.
3140						# $function - function name string,
3141						# used in the match pattern.
3142						#
3143						# Exit: Returns the signature expression
3144						# string, or undef if the pattern
3145						# does not match.
3146						#
3147						# Side effects: None.
3148						# --------------------------------------------------
3149						sub _extract_signature_expression {
3150	3			3	2201	my ($self, $stmt, $function) = @_;
3151
3152	3				5	my $content = $stmt->content;
3153
3154	3	100			171	if ($content =~ /^\ssignature_for\s+\Q$function\E\s=>\s(.+?);?\s$/s) {
3155	2				6	return $1;
3156						}
3157
3158	1				2	return;
3159						}
3160
3161						# --------------------------------------------------
3162						# _compile_signature_isolated
3163						#
3164						# Purpose: Compile and evaluate a Type::Params
3165						# signature expression in an isolated
3166						# process to extract parameter metadata
3167						# without polluting the current process.
3168						#
3169						# Only runs when the caller passed
3170						# allow_signature_exec => 1 to new().
3171						# Extracting parameter types from a
3172						# Type::Params signature_for() declaration
3173						# requires actually building the type
3174						# objects at runtime -- there is no purely
3175						# static way to do it -- so this is real
3176						# execution of an excerpt of the target
3177						# module's own source. Every other code
3178						# path in this module is static (PPI-only)
3179						# analysis that never runs the target's
3180						# code, so this one feature must be opted
3181						# into explicitly rather than triggered
3182						# implicitly by extract_all().
3183						#
3184						# A Safe compartment was previously tried
3185						# first as a "fast path" before falling
3186						# back to this subprocess unconditionally.
3187						# It was removed: Type::Params and
3188						# Types::Common pull in XS modules (e.g.
3189						# B.pm via Type::Params), and Safe cannot
3190						# host XS/dynamic loading at all, so the
3191						# compartment never succeeded for any real
3192						# signature_for() declaration -- it was
3193						# dead code that gave a false impression of
3194						# sandboxing while every real call fell
3195						# through to the unconditional subprocess
3196						# below.
3197						#
3198						# Entry: $function - function name string.
3199						# $signature_expr - Type::Params
3200						# signature expression
3201						# string.
3202						#
3203						# Exit: Returns a decoded JSON hashref
3204						# containing parameters and returns
3205						# metadata on success.
3206						# Returns undef without running anything if
3207						# allow_signature_exec was not enabled.
3208						# Croaks on unsafe expressions, timeout,
3209						# or compile errors.
3210						#
3211						# Side effects: May fork a child process with a
3212						# memory limit applied via
3213						# BSD::Resource if available.
3214						# Memory limiting is best-effort and
3215						# silently skipped on platforms where
3216						# BSD::Resource is unavailable.
3217						# --------------------------------------------------
3218						sub _compile_signature_isolated {
3219	10			10	10238	my ($self, $function, $signature_expr) = @_;
3220
3221	10	100			42	unless ($self->{allow_signature_exec}) {
3222						carp "Skipping Type::Params signature_for($function) extraction: ",
3223						'allow_signature_exec => 1 was not passed to new() ',
3224						'(this would execute code from the target module)'
3225	2	50			3	if $self->{verbose};
3226	2				3	return;
3227						}
3228
3229						# Remove comments
3230	8				14	$signature_expr =~ s/#.*$//mg;
3231
3232						# Reject obviously dangerous constructs. This is defense in depth
3233						# only, not a real security boundary -- it is a denylist of literal
3234						# tokens and cannot catch e.g. a symbolic-ref call built by string
3235						# concatenation. The actual control here is the allow_signature_exec
3236						# opt-in above: this code must never run against a module the caller
3237						# has not already decided to trust enough to execute.
3238						# Both checks unified into one croak so the message and class are consistent
3239	8	50	33		29	if ($signature_expr =~ $UNSAFE_KEYWORD_RE \|\| $signature_expr =~ $UNSAFE_CHAR_RE) {
3240	0				0	croak 'Unsafe signature expression -- rejected to prevent code execution';
3241						}
3242
3243	8				85	my $payload = <<'PERL';
3244						use strict;
3245						use warnings;
3246						use Type::Params -sigs;
3247						use Types::Common -types;
3248						use JSON::MaybeXS;
3249
3250						# Apply address-space limit passed from parent via env. Done here (in the
3251						# child) rather than in the parent so the parent's memory is never capped.
3252						if (my $limit = $ENV{_ATG_RLIMIT_AS}) {
3253						eval {
3254						require BSD::Resource;
3255						BSD::Resource::setrlimit(BSD::Resource::RLIMIT_AS(), $limit, $limit);
3256						};
3257						}
3258
3259						# Stub sub so Perl can parse it
3260						sub FUNCTION_NAME {}
3261
3262						# Create the Type::Params signature object
3263						my $sig = signature_for FUNCTION_NAME => SIGNATURE_EXPR;
3264
3265						# Extract parameters â€” guard against older Type::Params (< 2.x) where
3266						# signature_for() installs the constraint but returns undef rather than
3267						# the signature object, so ->parameters() would die.
3268						my @sig_params = (defined $sig && ref $sig && $sig->can('parameters'))
3269						? @{ $sig->parameters \|\| [] }
3270						: ();
3271						my $pos = 0;
3272						my @params;
3273
3274						# if ($sig->method) {
3275						# The $self value
3276						# push @params, {
3277						# name => 'arg0',
3278						# optional => 0,
3279						# position => $pos++,
3280						# };
3281						# }
3282
3283						for my $p (@sig_params) {
3284						my $name = ($p->can('name') && defined($p->name) && length($p->name))
3285						? $p->name
3286						: "arg$pos";
3287						push @params, {
3288						name => $name,
3289						optional => $p->optional ? 1 : 0,
3290						position => $pos,
3291						type => $p->type->name
3292						};
3293						$pos++;
3294						}
3295
3296						# Extract return type
3297						my $returns;
3298						if (my $r = $sig->returns_scalar) {
3299						$returns = {
3300						context => 'scalar',
3301						type => $r ? $r->name : 'unknown',
3302						};
3303						} elsif ($r = $sig->returns_list) {
3304						$returns = {
3305						context => 'list',
3306						type => $r ? $r->name : 'unknown',
3307						};
3308						}
3309
3310						print encode_json({
3311						parameters => \@params,
3312						returns => $returns,
3313						});
3314						PERL
3315
3316						# Substitute function name and signature expression
3317	8				42	$payload =~ s/FUNCTION_NAME/$function/g;
3318	8				34	$payload =~ s/SIGNATURE_EXPR/$signature_expr/;
3319
3320						# Run in an isolated Perl process
3321	8				25	my ($wtr, $rdr, $err) = (undef, undef, gensym);
3322	8				84	local %ENV;
3323
3324						# Pass the memory limit to the child via env so the child can apply
3325						# setrlimit on itself after exec. Must NOT call setrlimit here in the
3326						# parent: setrlimit(RLIMIT_AS) constrains the parent's own address
3327						# space, and when the parent later tries to allocate memory for test
3328						# framework teardown it would OOM and crash inside the Test::Builder
3329						# subtest context, producing a "context destroyed" error.
3330	8				25	$ENV{_ATG_RLIMIT_AS} = $MEMORY_LIMIT_BYTES;
3331
3332	8				50	my $pid = open3($wtr, $rdr, $err, $^X, '-T');
3333
3334	8				241	print $wtr $payload;
3335	8				22	close $wtr;
3336
3337	8 0			0	814 0	local $SIG{ALRM} = sub { croak 'Signature compile timeout' };
3338	8 8				8 16	eval { alarm($SIGNATURE_TIMEOUT_SECS) }; # no-op on Windows
3339
3340	8 8 8				54 14 24	my $stdout = do { local $/; <$rdr> };
3341	8 8 8				5 11 10	my $stderr = do { local $/; <$err> };
3342
3343	8 8				7 13	eval { alarm 0 };
3344
3345	8				21	waitpid($pid, 0);
3346
3347	8	100	67		19	if ($stderr && length $stderr) {
3348	1	50			2	carp "Error compiling signature:\n$stderr" if $self->{verbose};
3349	1				88	return;
3350						}
3351
3352						# Child may be killed by the kernel OOM killer (SIGKILL) before it can
3353						# write anything to stdout or stderr. Guard both cases so we degrade
3354						# gracefully rather than croaking with "malformed JSON".
3355	7	100	67		21	if (!defined($stdout) \|\| !length($stdout)) {
3356	4	50			9	carp 'Signature subprocess produced no output' if $self->{verbose};
3357	4				447	return;
3358						}
3359
3360	3 3				3 27	my $result = eval { decode_json($stdout) };
3361	3	50			7	if ($@) {
3362	3	50			6	carp "Error decoding signature output: $@" if $self->{verbose};
3363	3				270	return;
3364						}
3365	0				0	return $result;
3366						}
3367
3368						# --------------------------------------------------
3369						# _build_schema_from_meta
3370						#
3371						# Purpose: Convert the parameter and return type
3372						# metadata produced by
3373						# _compile_signature_isolated into a
3374						# standard schema hashref.
3375						#
3376						# Entry: $meta - hashref with 'parameters'
3377						# arrayref and optional
3378						# 'returns' hashref, as decoded
3379						# from the isolated compile
3380						# JSON output.
3381						#
3382						# Exit: Returns a schema hashref with input,
3383						# output, style, source, _notes, and
3384						# _confidence keys.
3385						#
3386						# Side effects: None.
3387						#
3388						# Notes: Unknown Type::Params type names are
3389						# mapped to 'string' with a note added
3390						# and confidence downgraded to 'medium'.
3391						# --------------------------------------------------
3392						sub _build_schema_from_meta {
3393	8			8	40	my ($self, $meta) = @_;
3394
3395	8				25	my %type_map = (
3396						Num => 'number',
3397						Int => 'integer',
3398						Str => 'string',
3399						Bool => 'boolean',
3400						Object => 'object',
3401						ArrayRef => 'array',
3402						HashRef => 'object',
3403						);
3404
3405	8				5	my $input;
3406	8				5	my $position = 0;
3407	8				9	my $confidence = 'high';
3408	8				8	my @notes = ('Type::Params detected');
3409
3410	8 8	50			7 12	foreach my $p (@{ $meta->{parameters} \|\| [] }) {
3411	8		100		11	my $type = $type_map{ $p->{type} } // 'string';
3412
3413	8	100			9	if (!exists $type_map{$p->{type}}) {
3414	1				2	push @notes, "Unknown type $p->{type}, defaulting to string";
3415	1				1	$confidence = 'medium';
3416						}
3417
3418						$input->{"arg$position"} = {
3419						type => $type,
3420						position => $position,
3421	8	100			19	optional => $p->{optional} ? 1 : 0,
3422						};
3423
3424	8				8	$position++;
3425						}
3426
3427	8				7	my $output;
3428
3429	8	100			10	if (my $ret = $meta->{returns}) {
3430	2		50		2	my $type = $type_map{ $ret->{type} } // 'string';
3431
3432	2	50			3	if (!exists $type_map{$ret->{type}}) {
3433	0				0	push @notes, "Unknown return type $ret->{type}, defaulting to string";
3434	0				0	$confidence = 'medium';
3435						}
3436
3437						$output = {
3438	2				6	type => $type,
3439						"_$ret->{context}_context" => { type => $type },
3440						};
3441						}
3442
3443						return {
3444	8				29	input => $input,
3445						output => $output,
3446						style => 'hash',
3447						source => 'validator',
3448						_notes => \@notes,
3449						_confidence => {
3450						input => $confidence,
3451						},
3452						};
3453						}
3454
3455						# --------------------------------------------------
3456						# _analyze_pod
3457						#
3458						# Purpose: Parse POD documentation for a method
3459						# and extract parameter names, types,
3460						# constraints, and optionality from
3461						# multiple POD patterns.
3462						#
3463						# Entry: $pod - string of POD content as
3464						# returned by _extract_pod_before.
3465						# May be undef or empty.
3466						#
3467						# Exit: Returns a hashref of parameter name
3468						# to parameter spec hashref. Returns an
3469						# empty hashref if no POD is provided
3470						# or no parameters are found.
3471						#
3472						# Side effects: Carps when a semantic type is
3473						# detected, advising the caller to
3474						# set config->properties.
3475						# Logs progress to stdout when
3476						# verbose is set.
3477						#
3478						# Notes: Three pattern strategies are tried
3479						# in order: (1) named Parameters section,
3480						# (2) inline $name - type format,
3481						# (3) =over/=item list. Parameters found
3482						# earlier take precedence over later
3483						# discoveries. Default values from POD
3484						# are merged in last.
3485						# --------------------------------------------------
3486						sub _analyze_pod {
3487	343			343	352	my ($self, $pod) = @_;
3488
3489	343	100			393	return {} unless $pod;
3490
3491	143				120	my %params;
3492	143				138	my $position_counter = 0;
3493
3494						# Check for positional arguments in method signature
3495						# Pattern: =head2 method_name($arg1, $arg2, $arg3)
3496	143	100			353	if ($pod =~ /=head2\s+\w+\s*$([^)]+)$/s) {
3497	36				58	my $sig = $1;
3498						# Extract parameter names in order
3499	36				88	my @sig_params = $sig =~ /\$(\w+)/g;
3500
3501						# Skip $self or $class
3502	36	50	33		125	shift @sig_params if @sig_params && $sig_params[0] =~ /^(self\|class\|pkg\|proto\|klass)$/i;
3503
3504						# Assign positions
3505	36				43	foreach my $param (@sig_params) {
3506	48		33		153	$params{$param}{position} //= $position_counter;
3507	48				99	$self->_log(" POD: $param has position $params{$param}{position}");
3508	48				57	$position_counter++;
3509						}
3510						}
3511
3512	143				252	$self->_log(" POD: Found $position_counter unnamed parameters to add to the position list");
3513
3514						# Pattern 1: Parse line-by-line in Parameters section
3515						# First, extract the Parameters section
3516	143				130	my $param_section;
3517	143	100 100			1414	if($pod =~ /(?:Parameters?\|Arguments?\|Inputs?):?\s\n((?:\s\$.*\n)+)/si) {
3518	30				42	$param_section = $1;
3519						} elsif ($pod =~ /^=head\d+\s+(?:Parameters?\|Arguments?\|Inputs?)\b.?\n(.?)(?=^=head\|\Z)/msi) {
3520	43				61	$param_section = $1;
3521						}
3522	143	100			196	if($param_section) {
3523	73				86	my $param_order = 0;
3524
3525	73				137	$self->_log(" POD: Scan for named parameters in '$param_section'");
3526						# Now parse each line that starts with $varname
3527	73				173	foreach my $line (split /\n/, $param_section) {
3528	407	50			401	if ($line =~ /C<\$(\w+)>\s*$(Required\|Mandatory)$/i) {
3529	0				0	$params{$1}{optional} = 0;
3530	0				0	$self->_log(" POD: $1 marked required from item header");
3531						}
3532
3533						# Match: $name - type (constraints), description
3534						# or: $name - type, description
3535						# or: $name - type
3536	407	100	67		673	if(($line =~ /^\s\$(\w+)\s-\s(\w+)(?:\s$([^)]+)$)?\s,?\s(.*)$/i) \|\|
3537						($line =~ /^\sC<\$(\w+)>\s-\s(\w+)(?:\s$([^)]+)$)?\s,?\s(.*)$/i)) {
3538	43				123	my ($name, $type, $constraint, $desc) = ($1, lc($2), $3, $4);
3539
3540						# Clean up
3541	43	100			111	$desc =~ s/^\s+\|\s+$//g if $desc;
3542
3543						# Skip common non-parameters
3544	43	100			98	next if $name =~ /^(self\|class\|pkg\|proto\|klass\|return\|returns?)$/i;
3545
3546	42		100		78	$params{$name} \|\|= { _source => 'pod' };
3547
3548						# If we haven't already assigned a position from the signature, use order in Parameters section
3549	42	100			53	unless (exists $params{$name}{position}) {
3550	16				14	$params{$name}{position} = $param_order++;
3551	16				22	$self->_log(" POD: $name has position $params{$name}{position} (from Parameters order)");
3552						}
3553
3554						# Normalize type names
3555	42	50			47	$type = 'integer' if $type eq 'int';
3556	42	50	33		80	$type = 'number' if $type eq 'num' \|\| $type eq 'float';
3557	42	50			36	$type = 'boolean' if $type eq 'bool';
3558	42	50			36	$type = 'arrayref' if $type eq 'array';
3559	42	50			42	$type = 'hashref' if $type eq 'hash';
3560
3561	42				57	$params{$name}{type} = $type;
3562
3563						# Parse constraints
3564	42	100			46	if($constraint) {
3565	7				13	$self->_parse_constraints($params{$name}, $constraint);
3566						}
3567
3568						# Check for optional/required in description OR constraint.
3569						# Use word boundaries to avoid matching "optionally" as "optional".
3570	42		100 100		71	my $full_text = ($constraint \|\| '') . ' ' . ($desc \|\| '');
3571	42	100 100			122	if ($full_text =~ /\boptional\b/i) {
3572	6				6	$params{$name}{optional} = 1;
3573	6				11	$self->_log(" POD: $name marked as optional");
3574						} elsif ($full_text =~ /required\|mandatory/i) {
3575	2				4	$params{$name}{optional} = 0;
3576	2				3	$self->_log(" POD: $name marked as required");
3577						}
3578
3579						# Detect semantic types:
3580	42	100			80	if ($desc =~ /\b(email\|url\|uri\|path\|filename)\b/i) {
3581						# TODO: ensure properties is set to 1 in $config
3582	2				82	carp('Manually set config->properties to 1 in ', $self->{'input_file'});
3583	2				324	$params{$name}{semantic} = lc($1);
3584						}
3585
3586						# Look for regex patterns
3587	42	100	100		77	if ($desc && $desc =~ m{matches?\s+(/[^/]+/\|qr/.+?/)}i) {
3588	1				1	$params{$name}{matches} = $1;
3589						}
3590
3591	42	100 100			101	$self->_log(" POD: Found parameter '$name' in parameters section, type=$type" .
3592						($constraint ? " ($constraint)" : '') .
3593						($desc ? " - $desc" : ''));
3594						}
3595						}
3596						}
3597
3598						# Pattern 2: Also try the inline format in case Parameters: section wasn't found
3599	143				393	while ($pod =~ /\$(\w+)\s-\s(string\|integer\|int\|number\|num\|float\|boolean\|bool\|arrayref\|array\|hashref\|hash\|object\|any)(?:\s$([^)]+)$)?\s,?\s(.)$/gim) {
3600	29				82	my ($name, $type, $constraint, $desc) = ($1, lc($2), $3, $4);
3601
3602						# Only process if we haven't already found this param in the Parameters section
3603	29	100			61	next if exists $params{$name};
3604
3605						# Clean up description - remove leading/trailing whitespace
3606	2	50			7	$desc =~ s/^\s+\|\s+$//g if $desc;
3607
3608						# Skip common words that aren't parameters
3609	2	100			5	next if $name =~ /^(self\|class\|pkg\|proto\|klass\|return\|returns?)$/i;
3610
3611	1		50		4	$params{$name} \|\|= { _source => 'pod' };
3612
3613						# Normalize type names
3614	1	50			1	$type = 'integer' if $type eq 'int';
3615	1	50	33		2	$type = 'number' if $type eq 'num' \|\| $type eq 'float';
3616	1	50			2	$type = 'boolean' if $type eq 'bool';
3617	1	50			1	$type = 'arrayref' if $type eq 'array';
3618	1	50			2	$type = 'hashref' if $type eq 'hash';
3619
3620	1				1	$params{$name}{type} = $type;
3621
3622						# Parse constraints
3623	1	50			2	if ($constraint) {
3624	0				0	$self->_parse_constraints($params{$name}, $constraint);
3625						}
3626
3627						# Check for optional/required in description.
3628						# Use word boundaries to avoid matching "optionally" as "optional".
3629	1	50			1	if ($desc) {
3630	1	50 50			5	if ($desc =~ /\boptional\b/i) {
3631	0				0	$params{$name}{optional} = 1;
3632						} elsif ($desc =~ /required\|mandatory/i) {
3633	0				0	$params{$name}{optional} = 0;
3634						}
3635
3636						# Look for regex patterns in description
3637	1	50			1	if ($desc =~ m{matches?\s+(/[^/]+/\|qr/.+?/)}i) {
3638	0				0	$params{$name}{matches} = $1;
3639						}
3640						}
3641
3642	1	50			4	$self->_log(" POD: Found parameter '$name' in the inline documentation, type=$type" .
3643						($constraint ? " ($constraint)" : ''));
3644						}
3645
3646						# Pattern 3: Parse =over /=item list (supports bullets and C<>)
3647	143				707	while ($pod =~ /=item\s+(?:\\s)?(?:C<)?\$(\w+)\b(?:>)?\s(?:-.)?\n?(.*?)(?==item\|\=back\|\=head)/sig) {
3648	23				31	my $name = $1;
3649	23				27	my $desc = $2;
3650
3651						# Never allow empty or undefined parameter names
3652	23	50	33		50	next unless defined $name && length $name;
3653
3654	23				69	$desc =~ s/^\s+\|\s+$//g;
3655
3656						# Skip common non-parameters
3657	23	50			40	next if $name =~ /^(self\|class\|pkg\|proto\|klass\|return\|returns?)$/i;
3658
3659	23		100		82	$params{$name} \|\|= { _source => 'pod' };
3660
3661						# Explicit typed form only:
3662						# $param - type (constraints)
3663	23	100			40	if ($desc =~ /^\s(string\|integer\|int\|number\|num\|float\|boolean\|bool\|array\|arrayref\|hash\|hashref\|any)\b(?:\s$([^)]+)$)?/i) {
3664	7				11	my $type = lc($1);
3665	7				8	my $constraint = $2;
3666
3667						# Normalize type names
3668	7	50			8	$type = 'integer' if $type eq 'int';
3669	7	50	33		13	$type = 'number' if $type eq 'num' \|\| $type eq 'float';
3670	7	50			8	$type = 'boolean' if $type eq 'bool';
3671	7	50			8	$type = 'arrayref' if $type eq 'array';
3672	7	50			7	$type = 'hashref' if $type eq 'hash';
3673
3674	7				8	$params{$name}{type} = $type;
3675
3676	7	100			9	if ($constraint) {
3677	3				7	$self->_parse_constraints($params{$name}, $constraint);
3678						}
3679
3680	7				10	$self->_log(" POD: Explicit type '$type' for $name");
3681						} else {
3682						# Heuristic inference from description text
3683	16	50 50 50 50			73	if ($desc =~ /\bstring\b/i) {
3684	0				0	$params{$name}{type} = 'string';
3685						} elsif ($desc =~ /\b(int\|integer)\b/i) {
3686	0				0	$params{$name}{type} = 'integer';
3687						} elsif ($desc =~ /\b(num\|number\|float)\b/i) {
3688	0				0	$params{$name}{type} = 'number';
3689						} elsif ($desc =~ /\b(bool\|boolean)\b/i) {
3690	0				0	$params{$name}{type} = 'boolean';
3691						}
3692						}
3693
3694						# Check for optional/required in description.
3695						# Use word boundaries to avoid matching "optionally" as "optional".
3696	23	100 100			75	if ($desc =~ /\boptional\b/i) {
3697	1				2	$params{$name}{optional} = 1;
3698						} elsif ($desc =~ /required\|mandatory/i) {
3699	7				8	$params{$name}{optional} = 0;
3700						}
3701
3702						# Look for regex patterns
3703	23	50			29	if ($desc =~ m{matches?\s+(/[^/]+/\|qr/.+?/)}i) {
3704	0				0	$params{$name}{matches} = $1;
3705						}
3706
3707	23				34	$self->_log(" POD: Found parameter '$name' from =item list");
3708						}
3709
3710						# Extract default values from POD
3711	143				282	my $pod_defaults = $self->_extract_defaults_from_pod($pod);
3712	143				247	foreach my $param (keys %$pod_defaults) {
3713	10	50			8	if (exists $params{$param}) {
3714	10				8	$params{$param}{_default} = $pod_defaults->{$param};
3715	10	100			11	$params{$param}{optional} = 1 unless defined $params{$param}{optional};
3716						$self->_log(sprintf(" POD: %s has default value: %s",
3717						$param,
3718	10	100			17	defined($pod_defaults->{$param}) ? $pod_defaults->{$param} : 'undef'
3719						));
3720						}
3721						}
3722
3723						# Default undocumented optionality: documented params are REQUIRED unless stated otherwise
3724	143				207	for my $name (keys %params) {
3725	86	50			152	next if $name =~ /^(self\|class\|pkg\|proto\|klass)$/i;
3726
3727						# TODO: if optionality was never explicitly set, assume required.
3728						# Currently disabled as it breaks some schemas â€” revisit in a future pass.
3729						# if (!exists $params{$name}{optional}) {
3730						# $params{$name}{optional} = 0;
3731						# $self->_log(" POD: $name assumed required (no optional/default specified)");
3732						# }
3733						}
3734
3735						# Pattern 0: =head3\|4 Input formal spec â€” highest-priority type source.
3736						# Runs last so positional matching can use positions set by earlier patterns.
3737						# Accepts positional array format: [ {type=>'...'}, ... ]
3738						# and named hash format: { name => {type=>'...'}, ... }
3739	143	100			442	if ($pod =~ /=head[34]\s+Input\b(.*?)(?==head\|\z)/si) {
3740	23				28	my $block = $1;
3741	23				39	$block =~ s/\A\s+//;
3742
3743	23	100 100			52	if ($block =~ /\A\[/) {
3744						# Positional format: each {â€¦} maps to the param at that array index.
3745	7				5	my $idx = 0;
3746	7				18	while ($block =~ /\{([^}]*)\}/g) {
3747	9				9	my $spec = $1;
3748	9 3		50		12 6	my ($name) = grep { ($params{$_}{position} // -1) == $idx }
3749						keys %params;
3750	9	100			32	if (defined $name) {
3751	3				3	$params{$name}{_from_input_spec} = 1;
3752	3	50			5	if (my $t = $self->_map_formal_input_type($spec)) {
3753	3				3	$params{$name}{type} = $t;
3754	3				4	$self->_log(" POD: $name type '$t' from =head Input (positional $idx)");
3755						}
3756	3	50			4	if ($spec =~ /\boptional\s=>\s(0\|1)/i) {
3757	0				0	$params{$name}{optional} = $1 + 0;
3758						}
3759						}
3760	9				17	$idx++;
3761						}
3762						} elsif ($block =~ /\A\{/) {
3763						# Named format: each 'name => {â€¦}' entry maps directly by name.
3764	11				38	while ($block =~ /\b(\w+)\s=>\s\{([^}]*)\}/g) {
3765	22				30	my ($name, $spec) = ($1, $2);
3766	22	100			45	next if $name =~ /^(self\|class\|pkg\|proto\|klass)$/i;
3767	13		100		26	$params{$name} //= { _source => 'pod' };
3768	13				14	$params{$name}{_from_input_spec} = 1;
3769	13	50			23	if (my $t = $self->_map_formal_input_type($spec)) {
3770	13				15	$params{$name}{type} = $t;
3771	13				20	$self->_log(" POD: $name type '$t' from =head Input (named)");
3772						}
3773	13	100			24	if ($spec =~ /\boptional\s=>\s(0\|1)/i) {
3774	2				3	$params{$name}{optional} = $1 + 0;
3775						}
3776	13	50			23	if ($spec =~ /\bmemberof\s=>\s\[([^\]]*)\]/i) {
3777	0				0	my $list_str = $1;
3778	0				0	my @vals;
3779	0				0	while ($list_str =~ /['"]([^'"]*)['"]/g) {
3780	0				0	push @vals, $1;
3781						}
3782	0	0			0	$params{$name}{memberof} = \@vals if @vals;
3783						}
3784	13	100			28	if ($spec =~ /\bmin\s=>\s(\d+)/i) {
3785	4				9	$params{$name}{min} = $1 + 0;
3786						}
3787	13	100			20	if ($spec =~ /\bmax\s=>\s(\d+)/i) {
3788	3				4	$params{$name}{max} = $1 + 0;
3789						}
3790	13	50			37	if ($spec =~ /\bisa\s=>\s['"]([^'"]+)['"]/i) {
3791	0				0	$params{$name}{isa} = $1;
3792						}
3793						}
3794						# A named-format Input spec signals a hash/named API. Positional
3795						# info from signature analysis is not meaningful here and causes
3796						# "param X missing position" errors when params are mixed.
3797	11				23	delete $params{$_}{position} for keys %params;
3798						}
3799						}
3800
3801	143				202	return \%params;
3802						}
3803
3804						# --------------------------------------------------
3805						# _map_formal_input_type
3806						#
3807						# Purpose: Extract and normalise the type string
3808						# from a parameter spec fragment such as
3809						# "type => 'scalar \| scalarref'".
3810						# Handles union types by returning the
3811						# canonical ATG type for the first
3812						# recognised alternative.
3813						#
3814						# Entry: $spec - text content of a { } block
3815						# from a =head3\|4 Input spec.
3816						#
3817						# Exit: Canonical type string, or undef when
3818						# no 'type' key is present or the value
3819						# is not a recognised type name.
3820						# --------------------------------------------------
3821						sub _map_formal_input_type {
3822	21			21	1320	my ($self, $spec) = @_;
3823						# Accept both quoted type => 'scalar' and unquoted Params::Validate
3824						# constants type => OBJECT (no quotes around the constant name).
3825	21	100			58	return undef unless $spec =~ /\btype\s=>\s(?:['"]([^'"]+)['"]\|([A-Z_]+))/i;
3826	20	100			38	my $raw = lc(defined($1) ? $1 : $2);
3827	20				23	$raw =~ s/\s+//g;
3828
3829	20				191	my %map = (
3830						scalar => 'string',
3831						scalarref => 'string',
3832						str => 'string',
3833						string => 'string',
3834						int => 'integer',
3835						integer => 'integer',
3836						num => 'number',
3837						number => 'number',
3838						float => 'number',
3839						bool => 'boolean',
3840						boolean => 'boolean',
3841						array => 'arrayref',
3842						arrayref => 'arrayref',
3843						hash => 'hashref',
3844						hashref => 'hashref',
3845						object => 'object',
3846						any => 'any',
3847						undef => 'undef',
3848						coderef => 'coderef',
3849						);
3850
3851	20				31	for my $t (split /\\|/, $raw) {
3852	20	100			83	return $map{$t} if exists $map{$t};
3853						}
3854	1				4	return undef;
3855						}
3856
3857						# --------------------------------------------------
3858						# _analyze_output
3859						#
3860						# Purpose: Orchestrate analysis of a method's
3861						# return value by combining POD return
3862						# section parsing, code return statement
3863						# analysis, boolean detection, context
3864						# detection, void detection, chaining
3865						# detection, and error convention
3866						# detection.
3867						#
3868						# Entry: $pod - POD string for the method.
3869						# $code - method body source string.
3870						# $method_name - name of the method being
3871						# analysed, used for
3872						# boolean heuristics.
3873						#
3874						# Exit: Returns a hashref describing the
3875						# output type and behaviour, or an empty
3876						# hashref if nothing could be determined.
3877						# Keys include: type, value, isa, and
3878						# various _* metadata keys.
3879						#
3880						# Side effects: Logs progress to stdout when
3881						# verbose is set.
3882						# --------------------------------------------------
3883						sub _analyze_output {
3884	333			333	2574	my ($self, $pod, $code, $method_name) = @_;
3885
3886	333				235	my %output;
3887
3888	333				580	$self->_analyze_output_from_pod(\%output, $pod);
3889	333				616	$self->_analyze_output_from_code(\%output, $code, $method_name);
3890	333				573	$self->_enhance_boolean_detection(\%output, $pod, $code, $method_name);
3891	333				607	$self->_detect_list_context(\%output, $code);
3892	333				531	$self->_detect_void_context(\%output, $code, $method_name);
3893	333				531	$self->_detect_chaining_pattern(\%output, $code);
3894	333				579	$self->_detect_error_conventions(\%output, $code);
3895
3896	333	100			679	$self->_validate_output(\%output) if keys %output;
3897
3898						# Don't return empty output
3899	333	100			1033	return (keys %output) ? \%output : {};
3900						}
3901
3902						# --------------------------------------------------
3903						# _analyze_output_from_pod
3904						#
3905						# Purpose: Parse the POD documentation for a
3906						# method's return value and populate
3907						# an output hashref with type, value,
3908						# and behaviour information.
3909						#
3910						# Entry: $output - hashref to populate
3911						# (modified in place).
3912						# $pod - POD string for the method.
3913						#
3914						# Exit: Returns nothing. Modifies $output
3915						# in place.
3916						#
3917						# Side effects: Logs detections to stdout when
3918						# verbose is set.
3919						#
3920						# Notes: Two patterns are tried: (1) a
3921						# 'Returns:' section of up to 3 lines,
3922						# and (2) an inline 'returns X' phrase.
3923						# The section pattern takes precedence.
3924						# --------------------------------------------------
3925						sub _analyze_output_from_pod {
3926	336			336	329	my ($self, $output, $pod) = @_;
3927	336 3696				391 3678	my %VALID_OUTPUT_TYPES = map { $_ => 1 }
3928						qw(string integer number float boolean arrayref hashref object coderef void undef);
3929
3930	336	100			623	if ($pod) {
3931						# Pattern 0: =head4 Output formal spec (highest priority â€” explicit over heuristic)
3932						# The outer container shape determines the return type:
3933						# (...) â€” list/array of items
3934						# [...] â€” arrayref (bare [] = empty/void, skip)
3935						# {...} â€” hashref spec; look for type => inside, or isa => for object
3936	138	100			418	if($pod =~ /=head4\s+Output\b(.*?)(?==head\|\z)/si) {
3937	16				24	my $block = $1;
3938	16				30	$block =~ s/^\s+//;
3939	16	100 50 100			59	if($block =~ /^\(/) {
3940	2				3	$output->{type} = 'array';
3941	2				3	$self->_log(" OUTPUT: type 'array' from =head4 Output list notation");
3942						} elsif($block =~ /^\[/) {
3943	0	0			0	unless($block =~ /^\[\s*\]/) {
3944	0				0	$output->{type} = 'arrayref';
3945	0				0	$self->_log(" OUTPUT: type 'arrayref' from =head4 Output arrayref notation");
3946						}
3947						} elsif($block =~ /^\{/) {
3948	10	50 0			58	if($block =~ /type\s=>\s['"]?(\w[\w:]?)['"]?\s[,}]/i) {
3949	10				13	my $type = lc($1);
3950	10	50			13	$type = 'hashref' if $type eq 'hash';
3951	10	50			11	$type = 'arrayref' if $type eq 'array';
3952	10	100 50			25	if($VALID_OUTPUT_TYPES{$type}) {
3953	3				5	$output->{type} = $type;
3954	3				6	$self->_log(" OUTPUT: type '$type' from =head4 Output formal spec");
3955						} elsif($block =~ /\bisa\s*=>/) {
3956	0				0	$output->{type} = 'object';
3957	0				0	$self->_log(" OUTPUT: type 'object' from =head4 Output isa spec");
3958						}
3959						} elsif($block =~ /\bisa\s*=>/) {
3960	0				0	$output->{type} = 'object';
3961	0				0	$self->_log(" OUTPUT: type 'object' from =head4 Output isa spec");
3962						}
3963						}
3964						}
3965
3966						# Pattern 1: Returns: section
3967						# Up to 3 lines
3968	138	100			247	if ($pod =~ /Returns?:\s+([^\n]+(?:\n[^\n]+){0,2})/si) {
3969	8				11	my $returns_desc = $1;
3970	8				23	$returns_desc =~ s/^\s+\|\s+$//g;
3971
3972	8				15	$self->_log(" OUTPUT: Found Returns section: $returns_desc");
3973
3974						# Try to infer type from description (skip if Pattern 0 already set type)
3975	8	100 100 50 100 50 50 100 50	33 67 67 33 67 33 33 67		119	if (!$output->{type} && $returns_desc =~ /\b(string\|text)\b/i) {
3976	1				2	$output->{type} = 'string';
3977						} elsif (!$output->{type} && $returns_desc =~ /\b(integer\|int\|count)\b/i) {
3978	1				1	$output->{type} = 'integer';
3979						} elsif (!$output->{type} && $returns_desc =~ /\b(float\|decimal\|number)\b/i) {
3980	0				0	$output->{type} = 'number';
3981						} elsif (!$output->{type} && $returns_desc =~ /\b(boolean\|true\|false)\b/i) {
3982	1				2	$output->{type} = 'boolean';
3983						} elsif (!$output->{type} && $returns_desc =~ /\b(array\|list)\b/i) {
3984	0				0	$output->{type} = 'arrayref';
3985						} elsif (!$output->{type} && $returns_desc =~ /\b(hash\|hashref\|dictionary)\b/i) {
3986	0				0	$output->{type} = 'hashref';
3987						} elsif (!$output->{type} && $returns_desc =~ /\b(object\|instance)\b/i) {
3988	2				3	$output->{type} = 'object';
3989						} elsif (!$output->{type} && $returns_desc =~ /\bundef\b/i) {
3990	0				0	$output->{type} = 'undef';
3991						}
3992
3993						# Look for specific values
3994	8	100 50 50			22	if ($returns_desc =~ /\b1\s+(?:on\s+success\|if\s+successful)\b/i) {
3995	1				1	$output->{value} = 1;
3996	1	50	33		2	if(defined($output->{'type'}) && ($output->{type} eq 'scalar')) {
3997	0				0	$output->{type} = 'boolean';
3998						} else {
3999	1		50		2	$output->{type} \|\|= 'boolean';
4000						}
4001	1				2	$self->_log(" OUTPUT: Returns 1 on success");
4002						} elsif ($returns_desc =~ /\b0\s+(?:on\s+failure\|if\s+fail)\b/i) {
4003	0				0	$output->{alt_value} = 0;
4004						} elsif ($returns_desc =~ /dies\s+on\s+(?:error\|failure)/i) {
4005	0				0	$output->{_STATUS} = 'LIVES';
4006	0				0	$self->_log(' OUTPUT: Should not die on success');
4007						}
4008	8	100			16	if ($returns_desc =~ /\b(true\|false)\b/i) {
4009	1		50		2	$output->{type} \|\|= 'boolean';
4010						}
4011	8	50			17	if ($returns_desc =~ /\bundef\b/i) {
4012	0				0	$output->{optional} = 1;
4013						}
4014						}
4015
4016						# Pattern 2: Inline "returns X"
4017	138	100	100		519	if((!$output->{type}) && ($pod =~ /returns?\s+(?:an?\s+)?(\w+)/i)) {
4018	45				74	my $type = lc($1);
4019
4020	45	100			86	$type = 'boolean' if $type =~ /^(true\|false\|bool)$/;
4021						# Skip if it's just a number (like "returns 1")
4022	45	50			55	$type = 'integer' if $type eq 'int';
4023	45	50			94	$type = 'number' if $type =~ /^(num\|float)$/;
4024	45	50			54	$type = 'arrayref' if $type eq 'array';
4025	45	50			68	$type = 'hashref' if $type eq 'hash';
4026
4027	45	100			73	if($type =~ /^\d+$/) {
4028	2	50	33		3	if($type eq '1' \|\| $type eq '0') {
4029						# Try hard to guess if the result is a boolean
4030	2	50 50			7	if($pod =~ /1 on success.+0 (on\|if) /i) {
4031	0				0	$type = 'boolean';
4032						} elsif($pod =~ /return 0 .+ 1 on success/) {
4033	0				0	$type = 'boolean';
4034						} else {
4035	2				4	$type = 'integer';
4036						}
4037						} else {
4038	0				0	$type = 'integer';
4039						}
4040						}
4041
4042	45	50	33		68	$type = 'arrayref' if !$type && $pod =~ /returns?\s+.+\slist\b/i;
4043						# $output->{type} = $type if $type && $type !~ /^\d+$/;
4044	45	100			63	if ($VALID_OUTPUT_TYPES{$type}) {
4045	15				23	$output->{type} = $type;
4046	15				29	$self->_log(" OUTPUT: Inferred type from POD: $type");
4047						} else {
4048	30				48	$self->_log(" OUTPUT: POD return type '$type' is not a valid type, ignoring");
4049						}
4050						}
4051						}
4052						}
4053
4054						# --------------------------------------------------
4055						# _extract_defaults_from_pod
4056						#
4057						# Purpose: Extract default values for parameters
4058						# from POD documentation using multiple
4059						# pattern strategies.
4060						#
4061						# Entry: $pod - POD string for the method.
4062						# May be undef or empty.
4063						#
4064						# Exit: Returns a hashref of parameter name
4065						# to cleaned default value. Returns an
4066						# empty hashref if no POD is provided
4067						# or no defaults are found.
4068						#
4069						# Side effects: None.
4070						#
4071						# Notes: Three strategies are tried: (1) lines
4072						# containing 'Default:' or 'Defaults to:',
4073						# (2) lines containing 'Optional, default',
4074						# (3) inline $name - type, default value
4075						# format. Parameter names are inferred
4076						# by scanning backwards from the default
4077						# phrase to the nearest $variable.
4078						# --------------------------------------------------
4079						sub _extract_defaults_from_pod {
4080	149			149	2562	my ($self, $pod) = @_;
4081
4082	149	100			187	return {} unless $pod;
4083
4084	148				127	my %defaults;
4085
4086						# Pattern 1: Default: 'value' or Defaults to: 'value'
4087	148				335	while ($pod =~ /(?:Default(?:s? to)?\|default(?:s? to)?)[:]\s*([^\n\r]+)/gi) {
4088	19				19	my $default_text = $1;
4089	19				12	my $match_pos = pos($pod);
4090	19				33	$default_text =~ s/^\s+\|\s+$//g;
4091
4092						# Look backwards in the POD to find the parameter name
4093	19				20	my $context = substr($pod, 0, $match_pos);
4094	19				43	my @param_matches = ($context =~ /\$(\w+)/g);
4095	19	50			19	my $param = $param_matches[-1] if @param_matches; # Last parameter before default
4096
4097	19	50			17	if ($param) {
4098						# Always clean the default value - let _clean_default_value handle everything
4099	19	50			19	if ($default_text =~ /(\w+)\s=\s(.+)$/) {
4100						# Has explicit param = value format in the default text
4101	0				0	my ($p, $value) = ($1, $2);
4102	0				0	$defaults{$p} = $self->_clean_default_value($value);
4103						} else {
4104						# Just a value, associate with the found param
4105	19				26	$defaults{$param} = $self->_clean_default_value($default_text, 0); # NOT from code
4106						}
4107						}
4108						}
4109
4110						# Pattern 2: Optional, default 'value'
4111	148				287	while ($pod =~ /Optional(?:,)?\s+(?:default\|value)\s[:=]?\s([^\n\r,;]+)/gi) {
4112	6				7	my $default_text = $1;
4113	6				6	my $match_pos = pos($pod);
4114	6				10	$default_text =~ s/^\s+\|\s+$//g;
4115
4116						# Look backwards for parameter name
4117	6				7	my $context = substr($pod, 0, $match_pos);
4118	6				15	my @param_matches = ($context =~ /\$(\w+)/g);
4119	6	50			7	if (@param_matches) {
4120	6				6	my $param = $param_matches[-1]; # Last parameter before the default
4121	6				5	$defaults{$param} = $self->_clean_default_value($default_text, 0);
4122						}
4123						}
4124
4125						# Pattern 3: In parameter descriptions: $param - type, default 'value'
4126	148				398	while ($pod =~ /\$(\w+)\s-\s\w+(?:$[^)]*$)?[,\s]+default\s+['"]?([^'",\n]+)['"]?/gi) {
4127	1				3	my ($param, $value) = ($1, $2);
4128	1				2	$defaults{$param} = $self->_clean_default_value($value, 0);
4129						}
4130
4131	148				191	return \%defaults;
4132						}
4133
4134						# --------------------------------------------------
4135						# _analyze_output_from_code
4136						#
4137						# Purpose: Analyse return statements in a method
4138						# body to infer the output type by
4139						# counting and classifying each return
4140						# expression.
4141						#
4142						# Entry: $output - hashref to populate
4143						# (modified in place).
4144						# $code - method body source string.
4145						# $method_name - method name string.
4146						#
4147						# Exit: Returns nothing. Modifies $output
4148						# in place.
4149						#
4150						# Side effects: Logs detections to stdout when
4151						# verbose is set.
4152						# --------------------------------------------------
4153						sub _analyze_output_from_code
4154						{
4155	335			335	397	my ($self, $output, $code, $method_name) = @_;
4156
4157	335	50			368	if ($code) {
4158						# Early boolean detection - check for consistent 1/0 returns
4159	335				985	my @all_returns = $code =~ /return\s+([^;]+);/g;
4160	335	100			368	if (@all_returns) {
4161	315				272	my $boolean_count = 0;
4162	315				257	my $total_count = scalar(@all_returns);
4163
4164	315				309	foreach my $ret (@all_returns) {
4165	352				770	$ret =~ s/^\s+\|\s+$//g;
4166						# Match 0 or 1, even with conditions
4167	352	100			538	$boolean_count++ if ($ret =~ /^(?:0\|1)(?:\s\|$)/);
4168						}
4169
4170						# If most returns are 0 or 1, strongly suggest boolean
4171	315	100	100		451	if ($boolean_count >= 2 && $boolean_count >= $total_count * 0.8) {
4172	5	50			8	unless ($output->{type}) {
4173	5				6	$output->{type} = 'boolean';
4174	5				12	$self->_log(" OUTPUT: Early detection - $boolean_count/$total_count returns are 0/1, setting boolean");
4175						}
4176						}
4177						}
4178
4179	335				287	my @return_statements;
4180
4181	335	100 100 100 50 100 100	100		1754	if ($code =~ /return\s+bless\s\{[^}]\}\s,\s['"]?(\w+)['"]?/s) {
4182						# Detect blessed refs
4183	2				3	$output->{type} = 'object';
4184	2	50			3	if($method_name eq 'new') {
4185						# If we found the new() method, the object we're returning should be a sensible one
4186	0	0	0		0	if($self->{_document} && (my $package_stmt = $self->{_document}->find_first('PPI::Statement::Package'))) {
4187	0				0	$output->{isa} = $package_stmt->namespace();
4188	0		0		0	$self->{_package_name} //= $output->{isa};
4189						}
4190						} else {
4191	2				4	$output->{isa} = $1;
4192						}
4193	2				4	$self->_log(" OUTPUT: Bless found, inferring type from code is $output->{isa}");
4194						} elsif ($code =~ /return\s+bless/s) {
4195	24				37	$output->{type} = 'object';
4196	24	100			44	if($method_name eq 'new') {
4197	22				32	$output->{isa} = $self->_extract_package_name();
4198	22				305	$self->_log(" OUTPUT: Bless found, inferring type from code is $output->{isa}");
4199						} else {
4200	2				2	$self->_log(' OUTPUT: Bless found, inferring type from code is object');
4201						}
4202						} elsif ($code =~ /return\s$\s[^)]+\s,\s[^)]+\s$\s;/) {
4203						# Detect array context returns - must end with semicolon to be actual return
4204	1				2	$output->{type} = 'array'; # Not arrayref - actual array
4205	1				1	$self->_log(' OUTPUT: Found array contect return');
4206						} elsif ($code =~ /return\s+bless[^,]+,\s*__PACKAGE__/) {
4207						# Detect: bless {}, __PACKAGE__
4208	0				0	$output->{type} = 'object';
4209						# Get package name from the extractor's stored document
4210	0	0			0	if ($self->{_document}) {
4211	0				0	my $pkg = $self->{_document}->find_first('PPI::Statement::Package');
4212	0	0			0	$output->{isa} = $pkg ? $pkg->namespace : 'UNKNOWN';
4213	0		0		0	$self->_log(' OUTPUT: Object blessed into __PACKAGE__: ' . ($output->{isa} \|\| 'UNKNOWN'));
4214	0		0		0	$self->{_package_name} //= $output->{isa};
4215						}
4216						} elsif ($code =~ /return\s*$([^)]+)$/) {
4217	1				2	my $content = $1;
4218	1	50			2	if ($content =~ /,/) { # Has comma = multiple values
4219	0				0	$output->{type} = 'array';
4220						}
4221						} elsif ($code =~ /return\s+\$self\s;/ && $code =~ /\$self\s->\s\{[^}]+\}\s=/) {
4222						# Returns $self for chaining
4223	7				9	$output->{type} = 'object';
4224	7	50			16	if ($self->{_document}) {
4225	7				14	my $pkg = $self->{_document}->find_first('PPI::Statement::Package');
4226	7	50			629	$output->{isa} = $pkg ? $pkg->namespace : 'UNKNOWN';
4227	7		50		102	$self->_log(' OUTPUT: Object chained into __PACKAGE__: ' . ($output->{isa} \|\| 'UNKNOWN'));
4228	7		33		12	$self->{_package_name} //= $output->{isa};
4229						}
4230						}
4231
4232						# Find all return statements
4233	335				743	while ($code =~ /return\s+([^;]+);/g) {
4234	352				453	my $return_expr = $1;
4235	352				512	push @return_statements, $return_expr;
4236						}
4237
4238	335	100			333	if (@return_statements) {
4239	315				606	$self->_log(' OUTPUT: Found ' . scalar(@return_statements) . ' return statement(s)');
4240
4241						# Analyze return patterns
4242	315				254	my %return_types;
4243
4244	315	100			364	if($output->{'type'}) {
4245	58				88	$return_types{$output->{'type'}} += 3; # Add weighting to what's already been found
4246						}
4247	315				219	my $min;
4248	315				331	foreach my $ret (@return_statements) {
4249	352				649	$ret =~ s/^\s+\|\s+$//g;
4250
4251						# Literal values
4252	352	100 100 100 50 100 50 100 100 50 50 50 50 50 50 100 100	100 100		2406	if ($ret eq '1' \|\| $ret eq '0') {
4253	33				49	$return_types{boolean}++;
4254						} elsif ($ret =~ /^['"]/) {
4255	22				62	$return_types{string}++;
4256						} elsif ($ret =~ /^-?\d+$/) {
4257	105				176	$return_types{integer}++;
4258						} elsif ($ret =~ /^-?\d+\.\d+$/) {
4259	0				0	$return_types{number}++;
4260						} elsif ($ret eq 'undef') {
4261	1				1	$return_types{undef}++;
4262						} elsif ($ret =~ /^\[/) {
4263						# Data structures
4264	0				0	$return_types{arrayref}++;
4265						} elsif ($ret =~ /^\{/) {
4266	1				1	$return_types{hashref}++;
4267						} elsif ($ret =~ m{
4268						# Numeric expressions (heuristic, medium confidence)
4269						# Don't match ->
4270						(?:
4271						\+ \| -\b \| \* \| / \| %
4272						\| \+\+ \| --
4273						)
4274						}x) {
4275	50				83	$return_types{number} += 2;
4276						} elsif ($ret =~ /\\|\\|\s*\d+\b/) {
4277						# Logical-or fallback with numeric literal (e.g. $x \|\| 200)
4278	0				0	$return_types{integer} += 2;
4279	0				0	$self->_log(" OUTPUT: Numeric fallback expression detected");
4280						} elsif($ret =~ /^length[\s\(]/) {
4281	0				0	$return_types{integer}++;
4282	0				0	$min = 0;
4283						} elsif($ret =~ /^pos[\s\(]/) {
4284	0				0	$return_types{integer}++;
4285	0				0	$min = 0;
4286						} elsif($ret =~ /^index[\s\(]/) {
4287	0				0	$return_types{integer}++;
4288	0				0	$min = -1;
4289						} elsif($ret =~ /^rindex[\s\(]/) {
4290	0				0	$return_types{integer}++;
4291	0				0	$min = -1;
4292						} elsif($ret =~ /^ord[\s\(]/) {
4293	0				0	$return_types{integer}++;
4294						} elsif ($ret =~ /=/ && $ret =~ /\$\w+/) {
4295						# Assignment returning a value (e.g. $self->{status} = $status)
4296						# If assignment involves a numeric literal or variable, assume numeric intent
4297	10	50			21	if ($ret =~ /\b\d+\b/) {
4298	0				0	$return_types{integer} += 2;
4299	0				0	$self->_log(" OUTPUT: Assignment with numeric value detected");
4300						} else {
4301	10				18	$return_types{scalar}++;
4302						}
4303						}
4304						# Variables/expressions
4305						elsif ($ret =~ /\$\w+/) {
4306	116	50 50 100 50 50			422	if ($ret =~ /\\\@/) {
4307	0				0	$return_types{arrayref}++;
4308						} elsif ($ret =~ /\\\%/) {
4309	0				0	$return_types{hashref}++;
4310						} elsif ($ret =~ /bless/) {
4311	3				6	$return_types{object} += 2; # Heigher weight
4312						} elsif ($ret =~ /^\{[^}]*\}$/) {
4313	0				0	$return_types{hashref}++;
4314						} elsif ($ret =~ /^\[[^\]]*\]$/) {
4315	0				0	$return_types{arrayref}++;
4316						} else {
4317	113				179	$return_types{scalar}++;
4318						}
4319						}
4320						}
4321
4322						# Determine most common return type
4323	315	100			360	if (keys %return_types) {
4324	311 55				512 119	my ($most_common) = sort { $return_types{$b} <=> $return_types{$a} } keys %return_types;
4325						# Prefer integer over scalar if numeric returns dominate
4326	311	100	67		507	if ($return_types{integer} && (!$return_types{string})) {
4327	104	100	67		128	if (!$output->{type} \|\| $output->{type} eq 'scalar') {
4328	102				107	$output->{type} = 'integer';
4329	102				121	$self->_log(" OUTPUT: Numeric returns dominate, forcing integer");
4330	102		50		212	$output->{_type_confidence} \|\|= 'low';
4331	102	50			88	if(defined($min)) {
4332	0				0	$output->{min} = $min;
4333						}
4334						}
4335						}
4336	311	100			394	unless ($output->{type}) {
4337	151				201	$output->{type} = $most_common;
4338
4339						# Assign confidence for inferred numeric expressions
4340	151	100			204	if ($most_common eq 'number') {
4341	34		50		104	$output->{_type_confidence} \|\|= 'medium';
4342	34	50			112	if(defined($min)) {
4343	0				0	$output->{min} = $min;
4344						}
4345						}
4346
4347	151				274	$self->_log(" OUTPUT: Inferred type from code: $most_common");
4348						}
4349						}
4350
4351						# Check for consistent single value returns
4352	315	100	100		846	if (@return_statements == 1 && $return_statements[0] eq '1') {
4353	24				32	$output->{value} = 1;
4354	24	50	33		59	$output->{type} = 'boolean' if !$output->{type} \|\| $output->{type} eq 'scalar';
4355	24	50			58	$self->_log(" OUTPUT: Type already set to '$output->{type}', overriding with boolean") if($output->{'type'});
4356						}
4357						} else {
4358						# No explicit return - might return nothing or implicit undef
4359	20				23	$self->_log(" OUTPUT: No explicit return statement found");
4360						}
4361						}
4362						}
4363
4364						# --------------------------------------------------
4365						# _enhance_boolean_detection
4366						#
4367						# Purpose: Apply additional boolean-specific
4368						# detection heuristics using a weighted
4369						# scoring system, to override weak
4370						# type assignments when there is strong
4371						# evidence of a boolean return.
4372						#
4373						# Entry: $output - output hashref
4374						# (modified in place).
4375						# $pod - POD string.
4376						# $code - method body source string.
4377						# $method_name - method name string.
4378						#
4379						# Exit: Returns nothing. Modifies $output
4380						# in place, setting type to 'boolean'
4381						# if the score reaches
4382						# $BOOLEAN_SCORE_THRESHOLD.
4383						#
4384						# Side effects: Logs scoring details to stdout when
4385						# verbose is set.
4386						#
4387						# Notes: Only fires when output type is
4388						# not yet set or is 'unknown'. Does not
4389						# override explicitly set types.
4390						# --------------------------------------------------
4391						sub _enhance_boolean_detection {
4392	334			334	416	my ($self, $output, $pod, $code, $method_name) = @_;
4393
4394	334				257	my $boolean_score = 0; # Track evidence for boolean return
4395
4396	334	100	67		763	return unless !$output->{type} \|\| $output->{type} eq 'unknown';
4397
4398						# Look for stronger boolean indicators
4399	26	100	67		43	if ($pod && !$output->{type}) {
4400						# Common boolean return patterns in POD
4401	4	50			10	if ($pod =~ /returns?\s+(?:true\|false\|1\|0)\s+(?:on\|for\|upon)\s+(?:success\|failure\|error\|valid\|invalid)/i) {
4402	0				0	$boolean_score += 30;
4403	0				0	$self->_log(' OUTPUT: Strong boolean indicator in POD (+30)');
4404						}
4405
4406						# Check for method names that suggest boolean returns
4407	4	50			15	if ($pod =~ /(?:method\|sub)\s+(\w+)/) {
4408	0				0	my $inferred_method_name = $1;
4409	0	0			0	if ($inferred_method_name =~ /^(is_\|has_\|can_\|should_\|contains_\|exists_)/) {
4410	0				0	$boolean_score += 20;
4411	0				0	$self->_log(" OUTPUT: Inferred method name '$inferred_method_name' suggests boolean return (+20)");
4412						}
4413						}
4414						}
4415
4416						# Analyze code for boolean patterns
4417	26	50			32	if ($code) {
4418						# Count boolean return idioms
4419	26				50	my $true_returns = () = $code =~ /return\s+1\s*;/g;
4420	26				39	my $false_returns = () = $code =~ /return\s+0\s*;/g;
4421
4422	26	50 100			62	if ($true_returns + $false_returns >= 2) {
4423	0				0	$boolean_score += 40;
4424	0				0	$self->_log(' OUTPUT: Multiple 1/0 returns suggest boolean (+40)');
4425						} elsif ($true_returns + $false_returns == 1) {
4426	2				2	$boolean_score += 10;
4427	2				2	$self->_log(' OUTPUT: Single 1/0 return (+10)');
4428						}
4429
4430						# Ternary operators that return booleans
4431	26	50			53	if ($code =~ /return\s+(?:\w+\s[!=]=\s\w+\|\w+\s>\s\w+\|\w+\s<\s\w+)\s\?\s(?:1\|0)\s:\s(?:1\|0)/) {
4432	0				0	$boolean_score += 25;
4433	0				0	$self->_log(' OUTPUT: Ternary with 1/0 suggests boolean (+25)');
4434						}
4435
4436						# Check for common boolean method patterns
4437	26	50			50	if ($code =~ /return\s+[!\$\@\%]/) {
4438						# Returns negation or existence check
4439	0				0	$boolean_score += 15;
4440	0				0	$self->_log(' OUTPUT: Returns negation/existence check (+15)');
4441						}
4442						}
4443
4444						# Check method name for boolean indicators
4445	26	50			28	if ($method_name) {
4446	26	100			48	if ($method_name =~ /^(?:is_\|has_\|can_\|should_\|contains_\|exists_\|check_\|verify_\|validate_)/) {
4447	2				1	$boolean_score += 25;
4448	2				4	$self->_log(" OUTPUT: Method name '$method_name' suggests boolean return (+25)");
4449						}
4450	26	50			40	if ($method_name =~ /_ok$/) {
4451	0				0	$boolean_score += 30;
4452	0				0	$self->_log(" OUTPUT: Method name '$method_name' ends with '_ok' (+30)");
4453						}
4454						}
4455
4456						# Apply boolean type if we have strong evidence
4457						# Override weak type assignments (like 'array' from false positive)
4458	26	100			52	if($boolean_score >= $BOOLEAN_SCORE_THRESHOLD) {
4459	2	50	20		7	if (!$output->{type} \|\| $output->{type} eq 'scalar' \|\| $output->{type} eq 'array' \|\| $output->{type} eq 'undef') {
4460	2		50		23	my $old_type = $output->{type} \|\| 'none';
4461	2				3	$output->{type} = 'boolean';
4462	2				4	$self->_log(" OUTPUT: Boolean score $boolean_score >= $BOOLEAN_SCORE_THRESHOLD, setting type to boolean (was: $old_type)");
4463						}
4464						}
4465						}
4466
4467						# --------------------------------------------------
4468						# _detect_list_context
4469						#
4470						# Purpose: Detect methods that return different
4471						# values depending on calling context
4472						# via wantarray, and methods that
4473						# return explicit lists.
4474						#
4475						# Entry: $output - output hashref (modified
4476						# in place).
4477						# $code - method body source string.
4478						#
4479						# Exit: Returns nothing. Modifies $output
4480						# in place, setting _context_aware,
4481						# _list_context, _scalar_context,
4482						# _list_return, and/or type keys.
4483						#
4484						# Side effects: Logs detections to stdout when
4485						# verbose is set.
4486						# --------------------------------------------------
4487						sub _detect_list_context {
4488	334			334	352	my ($self, $output, $code) = @_;
4489	334	50			344	return unless $code;
4490
4491						# Check for wantarray usage
4492	334	100			495	if ($code =~ /wantarray/) {
4493	5				6	$output->{_context_aware} = 1;
4494	5				7	$self->_log(' OUTPUT: Method uses wantarray - context sensitive');
4495
4496						# Debug: show what we're matching against
4497	5	100			10	if ($code =~ /(wantarray[^;]+;)/s) {
4498	4				12	$self->_log(" DEBUG wantarray line: $1");
4499						}
4500
4501	5	100 100 50			28	if ($code =~ /wantarray\s\?\s$([^)]+)$\s:\s([^;]+)/s) {
4502						# Pattern 1: wantarray ? (list, items) : scalar_value (with parens)
4503	1				2	my ($list_return, $scalar_return) = ($1, $2);
4504	1				3	$self->_log(" DEBUG list (with parens): [$list_return], scalar: [$scalar_return]");
4505
4506	1				3	$output->{_list_context} = $self->_infer_type_from_expression($list_return);
4507	1				2	$output->{_scalar_context} = $self->_infer_type_from_expression($scalar_return);
4508	1				2	$self->_log(' OUTPUT: Detected context-dependent returns (parenthesized)');
4509						} elsif ($code =~ /wantarray\s\?\s([^:]+?)\s:\s([^;]+)/s) {
4510						# Pattern 2: wantarray ? @array : scalar (no parens around list)
4511	3				7	my ($list_return, $scalar_return) = ($1, $2);
4512						# Clean up
4513	3				6	$list_return =~ s/^\s+\|\s+$//g;
4514	3				7	$scalar_return =~ s/^\s+\|\s+$//g;
4515
4516	3				5	$self->_log(" DEBUG list (no parens): [$list_return], scalar: [$scalar_return]");
4517
4518	3				5	$output->{_list_context} = $self->_infer_type_from_expression($list_return);
4519	3				5	$output->{_scalar_context} = $self->_infer_type_from_expression($scalar_return);
4520	3				4	$self->_log(' OUTPUT: Detected context-dependent returns (non-parenthesized)');
4521						} elsif ($code =~ /return[^;]unless\s+wantarray.?return\s*$([^)]+)$/s) {
4522						# Pattern 3: return unless wantarray; return (list);
4523	1				2	$output->{_list_context} = { type => 'array' };
4524	1				1	$self->_log(' OUTPUT: Detected list context return after wantarray check');
4525						}
4526						}
4527
4528						# Detect explicit list returns (multiple values in parentheses)
4529						# Avoid false positives from function calls
4530	334	100			551	if ($code =~ /return\s$\s([^)]+)\s$\s;/) {
4531	4				6	my $content = $1;
4532
4533						# Count commas outside of nested structures, jumping over each
4534						# balanced bracketed block in one step via extract_bracketed
4535	4				353	require Text::Balanced;
4536	4				4294	my $comma_count = 0;
4537	4				4	my $rest = $content;
4538	4				7	while (length $rest) {
4539	44	100			43	if (substr($rest, 0, 1) =~ /[(\[{]/) {
4540	5				8	my $extracted = Text::Balanced::extract_bracketed($rest, '(){}[]');
4541	5	50			357	last unless defined $extracted; # Unbalanced brackets
4542	5				5	next;
4543						}
4544	39	100			60	$comma_count++ if substr($rest, 0, 1) eq ',';
4545	39				58	$rest = substr($rest, 1);
4546						}
4547
4548	4	100	67		15	if ($comma_count > 0 && $content !~ /\b(?:bless\|new)\b/) {
4549						# Multiple values returned
4550	3	50	67		7	unless ($output->{type} && $output->{type} eq 'boolean') {
4551	3				4	$output->{type} = 'array';
4552	3				4	$output->{_list_return} = $comma_count + 1;
4553	3				8	$self->_log(' OUTPUT: Returns list of ' . ($comma_count + 1) . ' values');
4554						}
4555						}
4556						}
4557						}
4558
4559						# --------------------------------------------------
4560						# _detect_void_context
4561						#
4562						# Purpose: Detect methods that return nothing
4563						# meaningful (void context), methods
4564						# that always return 1 as a success
4565						# indicator, and methods whose name
4566						# suggests void context (setters,
4567						# mutators, loggers).
4568						#
4569						# Entry: $output - output hashref
4570						# (modified in place).
4571						# $code - method body source string.
4572						# $method_name - method name string.
4573						#
4574						# Exit: Returns nothing. Modifies $output
4575						# in place, setting _void_context,
4576						# _success_indicator, and/or type.
4577						#
4578						# Side effects: Logs detections to stdout when
4579						# verbose is set.
4580						# --------------------------------------------------
4581						sub _detect_void_context {
4582	334			334	986	my ($self, $output, $code, $method_name) = @_;
4583	334	50			315	return unless $code;
4584
4585	334				468	$self->_log(" DEBUG _detect_void_context called for $method_name");
4586
4587						# Methods that typically don't return meaningful values
4588	334				1299	my $void_patterns = {
4589						'setter' => qr/^set_\w+$/,
4590						'mutator' => qr/^(?:add\|remove\|delete\|clear\|reset\|update)_/,
4591						'logger' => qr/^(?:log\|debug\|warn\|error\|info)$/,
4592						'printer' => qr/^(?:print\|say\|dump)_/,
4593						};
4594
4595						# Check if method name suggests void context
4596	334				455	foreach my $type (keys %$void_patterns) {
4597	1323	100			2199	if ($method_name =~ $void_patterns->{$type}) {
4598	14				21	$output->{_void_context_hint} = $type;
4599	14				23	$self->_log(" OUTPUT: Method name suggests $type (typically void context)");
4600	14				15	last;
4601						}
4602						}
4603
4604						# Analyze return statements
4605	334				744	my @returns = $code =~ /return\s([^;]);/g;
4606
4607	334				590	$self->_log(' DEBUG Found ' . scalar(@returns) . ' return statements');
4608
4609						# Count different return patterns
4610	334				304	my $no_value_returns = 0;
4611	334				245	my $true_returns = 0;
4612	334				226	my $self_returns = 0;
4613
4614	334				297	foreach my $ret (@returns) {
4615	355				622	$ret =~ s/^\s+\|\s+$//g;
4616	355				480	$self->_log(" DEBUG return value: [$ret]");
4617	355	100			375	$no_value_returns++ if $ret eq '';
4618	355	100			446	$no_value_returns++ if($ret =~ /^(if\|unless)\s/);
4619	355	100			321	$true_returns++ if $ret eq '1';
4620	355	100			309	$self_returns++ if $ret eq '$self';
4621	355	100			424	if ($ret =~ /\?\s1\s:\s*0\b/) {
4622						# Strong boolean signal: ternary returning 1/0
4623	12				9	$true_returns++;
4624						# $self->_log(" OUTPUT: Ternary 1:0 return detected, treating as boolean (+40)");
4625	12				13	$self->_log(' OUTPUT: Ternary 1:0 return detected, treating as boolean');
4626						}
4627						}
4628
4629	334				263	my $total_returns = scalar(@returns);
4630
4631	334				585	$self->_log(" DEBUG no_value=$no_value_returns, true=$true_returns, self=$self_returns, total=$total_returns");
4632
4633						# Void context indicators
4634	334	100 100	100 75		1162	if ($no_value_returns > 0 && $no_value_returns == $total_returns) {
4635	6				8	$output->{_void_context} = 1;
4636	6				7	$output->{type} = 'void'; # This should override any previous type
4637	6				6	$self->_log(' OUTPUT: All returns are empty - void context method');
4638						} elsif ($true_returns > 0 && $true_returns == $total_returns && $total_returns >= 1) {
4639						# Methods that always return true (success indicator)
4640	37				51	$output->{_success_indicator} = 1;
4641						# Don't override type if already set to boolean
4642	37	100	100		97	unless ($output->{type} && $output->{type} eq 'boolean') {
4643	5				8	$output->{type} = 'boolean';
4644						}
4645	37				46	$self->_log(' OUTPUT: Always returns 1 - success indicator pattern');
4646						}
4647						}
4648
4649						# --------------------------------------------------
4650						# _detect_chaining_pattern
4651						#
4652						# Purpose: Detect methods that return $self for
4653						# fluent interface chaining, by counting
4654						# the proportion of return statements
4655						# that return $self.
4656						#
4657						# Entry: $output - output hashref (modified
4658						# in place).
4659						# $code - method body source string.
4660						#
4661						# Exit: Returns nothing. Modifies $output
4662						# in place, setting type to 'object',
4663						# _returns_self to 1, and isa to the
4664						# current package name when the
4665						# proportion of $self returns is >= 0.8.
4666						#
4667						# Side effects: Logs detection to stdout when
4668						# verbose is set.
4669						# --------------------------------------------------
4670						sub _detect_chaining_pattern {
4671	333			333	356	my ($self, $output, $code) = @_;
4672	333	50			310	return unless $code;
4673
4674						# Count returns of $self
4675	333				261	my $self_returns = 0;
4676	333				302	my $total_returns = 0;
4677
4678	333				685	while ($code =~ /return\s+([^;]+);/g) {
4679	349				421	my $ret = $1;
4680	349				633	$ret =~ s/^\s+\|\s+$//g;
4681	349				260	$total_returns++;
4682	349	100			474	$self_returns++ if $ret eq '$self';
4683						}
4684
4685						# If most/all returns are $self, it's a chaining method
4686	333	100	67		483	if ($self_returns > 0 && $total_returns > 0) {
4687	9				26	my $ratio = $self_returns / $total_returns;
4688
4689	9	100			33	if ($ratio >= 0.8) {
4690	7				8	$output->{type} = 'object';
4691	7				10	$output->{_returns_self} = 1;
4692
4693						# Get the class name
4694	7	100			14	if ($self->{_document}) {
4695	6				10	my $pkg = $self->{_document}->find_first('PPI::Statement::Package');
4696	6	50			428	$output->{isa} = $pkg ? $pkg->namespace : 'UNKNOWN';
4697	6		33		72	$self->{_package_name} //= $output->{isa};
4698						}
4699
4700	7				15	$self->_log(" OUTPUT: Chainable method - returns \$self ($self_returns/$total_returns returns)");
4701						}
4702						}
4703						}
4704
4705						# --------------------------------------------------
4706						# _detect_error_conventions
4707						#
4708						# Purpose: Analyse how a method signals errors
4709						# by detecting patterns such as
4710						# 'return undef if', implicit bare
4711						# returns, empty list returns, 0/1
4712						# boolean error patterns, and eval
4713						# exception handling.
4714						#
4715						# Entry: $output - output hashref (modified
4716						# in place).
4717						# $code - method body source string.
4718						#
4719						# Exit: Returns nothing. Modifies $output
4720						# in place, setting _error_handling,
4721						# _error_return, and
4722						# _success_failure_pattern keys.
4723						#
4724						# Side effects: Logs detections to stdout when
4725						# verbose is set.
4726						# --------------------------------------------------
4727						sub _detect_error_conventions {
4728	334			334	318	my ($self, $output, $code) = @_;
4729
4730	334	50			306	return unless $code;
4731
4732	334				377	$self->_log(' DEBUG _detect_error_conventions called');
4733
4734	334				249	my %error_patterns;
4735
4736						# Pattern 1: return undef if/unless condition
4737	334				496	while ($code =~ /return\s+undef\s+(?:if\|unless)\s+([^;]+);/g) {
4738	7 7				5 11	push @{$error_patterns{undef_on_error}}, $1;
4739	7				15	$self->_log(" DEBUG Found 'return undef' pattern");
4740						}
4741
4742						# Pattern 2: return if/unless (implicit undef)
4743	334				589	while ($code =~ /return\s+(?:if\|unless)\s+([^;]+);/g) {
4744	7 7				8 11	push @{$error_patterns{implicit_undef}}, $1;
4745	7				9	$self->_log(" DEBUG Found implicit undef pattern");
4746						}
4747
4748						# Pattern 3: return () - matches with or without conditions
4749	334	100			470	if ($code =~ /return\s$\s$\s*(?:if\|unless\|;)/) {
4750	3				4	$error_patterns{empty_list} = 1;
4751	3				3	$self->_log(" DEBUG Found empty list return");
4752						}
4753
4754						# Pattern 4: return 0/1 pattern (indicates boolean with error handling)
4755	334				244	my $zero_returns = 0;
4756	334				239	my $one_returns = 0;
4757						# Match "return 0" or "return 1" followed by anything (condition or semicolon)
4758	334				610	while ($code =~ /return\s+(0\|1)\s*(?:;\|if\|unless)/g) {
4759	41	100			59	if ($1 eq '0') {
4760	9				10	$zero_returns++;
4761						} else {
4762	32				38	$one_returns++;
4763						}
4764						}
4765
4766	334	100	100		406	if ($zero_returns > 0 && $one_returns > 0) {
4767	5				8	$error_patterns{zero_on_error} = 1;
4768	5				8	$self->_log(" DEBUG Found 0/1 return pattern ($zero_returns zeros, $one_returns ones)");
4769						}
4770
4771						# Pattern 5: Exception handling with eval
4772	334	100			427	if ($code =~ /eval\s*\{/) {
4773						# Check if there's error handling after eval
4774	3	50			15	if ($code =~ /eval\s\{.?\}[^}](?:if\s\(\s*\$\@\|catch\|return\s+undef)/s) {
4775	3				4	$error_patterns{exception_handling} = 1;
4776	3				5	$self->_log(' DEBUG Found exception handling with eval');
4777						}
4778						}
4779
4780						# Detect success/failure return pattern
4781	334				604	my @all_returns = $code =~ /return\s+([^;]+);/g;
4782	334 353				371 517	my $has_undef = grep { /^\sundef\s(?:if\|unless\|$)/ } @all_returns;
4783	334 353		67		283 787	my $has_value = grep { !/^\sundef\s$/ && !/^\s*$/ } @all_returns;
4784
4785	334	50	50		426	if ($has_undef && $has_value && scalar(@all_returns) >= 2) {
4786	6				7	$output->{_success_failure_pattern} = 1;
4787	6				7	$self->_log(" OUTPUT: Uses success/failure return pattern");
4788						}
4789
4790						# Store error conventions in output
4791	334	100			326	if(scalar(keys %error_patterns)) {
4792	20				30	$output->{_error_handling} = \%error_patterns;
4793
4794						# Determine primary error convention
4795	20	100 100 100 100			51	if ($error_patterns{undef_on_error}) {
4796	5				4	$output->{_error_return} = 'undef';
4797	5				6	$self->_log(" OUTPUT: Returns undef on error");
4798						} elsif ($error_patterns{implicit_undef}) {
4799	6				8	$output->{_error_return} = 'undef';
4800	6				9	$self->_log(" OUTPUT: Returns implicit undef on error");
4801						} elsif ($error_patterns{empty_list}) {
4802	3				6	$output->{_error_return} = 'empty_list';
4803	3				3	$self->_log(" OUTPUT: Returns empty list on error");
4804						} elsif ($error_patterns{zero_on_error}) {
4805	5				7	$output->{_error_return} = 'false';
4806	5				7	$self->_log(" OUTPUT: Returns 0/false on error");
4807						}
4808
4809	20	100			37	if ($error_patterns{exception_handling}) {
4810	3				4	$self->_log(" OUTPUT: Has exception handling");
4811						}
4812						} else {
4813	314				402	delete $output->{_error_handling};
4814						}
4815						}
4816
4817						# --------------------------------------------------
4818						# _infer_type_from_expression
4819						#
4820						# Purpose: Infer the data type of a return
4821						# expression string by matching it
4822						# against common Perl literal and
4823						# variable patterns.
4824						#
4825						# Entry: $expr - return expression string,
4826						# trimmed of leading and
4827						# trailing whitespace.
4828						# May be undef.
4829						#
4830						# Exit: Returns a type hashref of the form
4831						# { type => '...' } and optionally
4832						# { min => N }. Defaults to
4833						# { type => 'scalar' } when no
4834						# pattern matches.
4835						#
4836						# Side effects: None.
4837						# --------------------------------------------------
4838						sub _infer_type_from_expression {
4839	37			37	647	my ($self, $expr) = @_;
4840
4841	37	100			41	return { type => 'scalar' } unless defined $expr;
4842
4843	35				71	$expr =~ s/^\s+\|\s+$//g;
4844
4845						# Check for multiple comma-separated values (indicates array/list)
4846	35	100			48	if ($expr =~ /,/) {
4847	5				635	require Text::Balanced;
4848	5				8372	my $comma_count = 0;
4849	5				6	my $rest = $expr;
4850	5				9	while (length $rest) {
4851	42	100			39	if (substr($rest, 0, 1) =~ /[(\[{]/) {
4852	5				10	my $extracted = Text::Balanced::extract_bracketed($rest, '(){}[]');
4853	5	50			384	last unless defined $extracted; # Unbalanced brackets
4854	5				5	next;
4855						}
4856	37	100			33	$comma_count++ if substr($rest, 0, 1) eq ',';
4857	37				32	$rest = substr($rest, 1);
4858						}
4859
4860	5	100			8	if ($comma_count > 0) {
4861	3				8	return { type => 'array' };
4862						}
4863						}
4864
4865						# Check for @ prefix (array)
4866	32	100	75		80	if ($expr =~ /^\@\w+/ \|\| $expr =~ /^qw\(/ \|\| $expr =~ /^\@\{/) {
4867	6				14	return { type => 'array' };
4868						}
4869
4870						# Check for scalar() function - returns count
4871	26	100			38	if ($expr =~ /scalar\s*\(/) {
4872	4				7	return { type => 'integer', min => 0 };
4873						}
4874
4875						# Check for array reference
4876	22	100	100		44	if ($expr =~ /^\[/ \|\| $expr =~ /^\\\@/) {
4877	4				11	return { type => 'arrayref' };
4878						}
4879
4880						# Check for hash reference
4881	18	100	100		34	if ($expr =~ /^\{/ \|\| $expr =~ /^\\\%/) {
4882	3				10	return { type => 'hashref' };
4883						}
4884
4885						# Check for hash
4886	15	50	33		28	if ($expr =~ /^\%\w+/ \|\| $expr =~ /^\%\{/) {
4887	0				0	return { type => 'hash' };
4888						}
4889
4890						# Check for strings
4891	15	100	67		34	if ($expr =~ /^['"]/ \|\| $expr =~ /['"]$/) {
4892	2				5	return { type => 'string' };
4893						}
4894
4895						# Check for booleans first â€” must come before the integer check
4896						# since /^-?\d+$/ would otherwise match 0 and 1 as integers
4897	13	100			16	if($expr =~ /^[01]$/) {
4898	4				10	return { type => 'boolean' };
4899						}
4900
4901						# Check for integers
4902	9	100			15	if($expr =~ /^-?\d+$/) {
4903	4				11	return { type => 'integer' };
4904						}
4905
4906	5	100			13	if ($expr =~ /^-?\d+\.\d+$/) {
4907	2				6	return { type => 'number' };
4908						}
4909
4910						# Check for objects
4911	3	50			9	if ($expr =~ /bless/) {
4912	0				0	return { type => 'object' };
4913						}
4914
4915	3	100			7	if($expr =~ /\blength\s*\(/) {
4916	2				5	return { type => 'integer', min => 0 };
4917						}
4918
4919						# Default to scalar
4920	1				2	return { type => 'scalar' };
4921						}
4922
4923						# --------------------------------------------------
4924						# _detect_chaining_from_pod
4925						#
4926						# Purpose: Check POD documentation for explicit
4927						# indications that a method is chainable
4928						# or part of a fluent interface.
4929						#
4930						# Entry: $output - output hashref (modified
4931						# in place).
4932						# $pod - POD string for the method.
4933						#
4934						# Exit: Returns nothing. Sets _returns_self
4935						# in $output if chaining keywords are
4936						# found.
4937						#
4938						# Side effects: Logs detection to stdout when
4939						# verbose is set.
4940						# --------------------------------------------------
4941						sub _detect_chaining_from_pod {
4942	5			5	14	my ($self, $output, $pod) = @_;
4943	5	100			9	return unless $pod;
4944
4945						# Look for explicit chaining documentation
4946	4	100	80		22	if ($pod =~ /returns?\s+(?:\$)?self\b/i \|\|
4947						$pod =~ /chainable/i \|\|
4948						$pod =~ /fluent\s+interface/i \|\|
4949						$pod =~ /method\s+chaining/i) {
4950
4951	3				4	$output->{_returns_self} = 1;
4952	3				4	$self->_log(" OUTPUT: POD indicates chainable/fluent interface");
4953						}
4954						}
4955
4956						# --------------------------------------------------
4957						# _validate_output
4958						#
4959						# Purpose: Apply basic sanity checks to the
4960						# assembled output hashref and warn
4961						# about suspicious type combinations,
4962						# normalising clearly invalid types to
4963						# 'string'.
4964						#
4965						# Entry: $output - output hashref (modified
4966						# in place).
4967						#
4968						# Exit: Returns nothing. May modify type key
4969						# in $output. Logs warnings to stdout
4970						# when verbose is set.
4971						#
4972						# Side effects: None.
4973						# --------------------------------------------------
4974						sub _validate_output {
4975	324			324	2520	my ($self, $output) = @_;
4976
4977						# Warn about suspicious combinations
4978	324	100	100		719	if (defined $output->{type} && $output->{type} eq 'boolean' && !defined($output->{value})) {
4979	18				25	$self->_log(' WARNING Boolean type without value - may want to set value: 1');
4980						}
4981	324	50	50		472	if ($output->{value} && defined $output->{type} && $output->{type} ne 'boolean') {
4982	0				0	$self->_log(" WARNING Value set but type is not boolean: $output->{type}");
4983						}
4984	324 2916				376 2663	my %valid_types = map { $_ => 1 } qw(string integer number boolean array arrayref hashref object void);
4985	324	100			896	if(exists $output->{type}) {
4986	319	100			1066	if(!$valid_types{$output->{type}}) {
4987	73				145	$self->_log(" WARNING Output value type is unknown: '$output->{type}', setting to string");
4988	73				195	$output->{type} = 'string';
4989						}
4990						}
4991						}
4992
4993						# --------------------------------------------------
4994						# _parse_constraints
4995						#
4996						# Purpose: Parse a constraint string extracted
4997						# from POD documentation and populate
4998						# min, max, or other constraint fields
4999						# in a parameter hashref.
5000						#
5001						# Entry: $param - hashref for the parameter
5002						# being annotated (modified
5003						# in place).
5004						# $constraint - the constraint string,
5005						# e.g. '3-50', 'positive',
5006						# '>= 0', 'min 3'.
5007						#
5008						# Exit: Returns nothing. Modifies $param in
5009						# place by setting min and/or max keys.
5010						#
5011						# Side effects: Logs min/max values to stdout when
5012						# verbose is set.
5013						# --------------------------------------------------
5014						sub _parse_constraints {
5015	25			25	2966	my ($self, $param, $constraint) = @_;
5016
5017						# Range: "3-50" or "1-100 chars"
5018	25	100 100 100 100 100 100 100			138	if ($constraint =~ /(\d+)\s-\s(\d+)/) {
5019	8				28	$param->{min} = $1;
5020	8				15	$param->{max} = $2;
5021						}
5022						elsif ($constraint =~ /(\d+)\s\.\.\s(\d+)/) {
5023						# Range: 0..19
5024	2				3	$param->{min} = $1;
5025	2				4	$param->{max} = $2;
5026						}
5027						# Minimum: "min 3" or "at least 5"
5028						elsif ($constraint =~ /(?:min\|minimum\|at least)\s*(\d+)/i) {
5029	4				5	$param->{min} = $1;
5030						}
5031						# Maximum: "max 50" or "up to 100"
5032						elsif ($constraint =~ /(?:max\|maximum\|up to)\s*(\d+)/i) {
5033	3				6	$param->{max} = $1;
5034						}
5035						# Positive
5036						elsif ($constraint =~ /positive/i) {
5037	2	100	67		6	$param->{min} = 1 if $param->{type} && $param->{type} eq 'integer';
5038	2	100	67		7	$param->{min} = 0.01 if $param->{type} && $param->{type} eq 'number';
5039						}
5040						# Non-negative
5041						elsif ($constraint =~ /non-negative/i) {
5042	2				4	$param->{min} = 0;
5043						} elsif($constraint =~ /^(\S+)\s+(.+)$/) {
5044	2				3	my ($op, $val) = ($1, $2);
5045	2	50			5	if(looks_like_number($val)) {
5046	0	0 0 0 0			0	if ($op eq '<') {
5047	0				0	$param->{max} = $val - 1;
5048						} elsif ($op eq '<=') {
5049	0				0	$param->{max} = $val;
5050						} elsif ($op eq '>') {
5051	0				0	$param->{min} = $val + 1;
5052						} elsif ($op eq '>=') {
5053	0				0	$param->{min} = $val;
5054						}
5055						}
5056						}
5057
5058	25	100			34	if(defined($param->{max})) {
5059	13				24	$self->_log(" Set max to $param->{max}");
5060						}
5061	25	100			33	if(defined($param->{min})) {
5062	18				28	$self->_log(" Set min to $param->{min}");
5063						}
5064						}
5065
5066						# --------------------------------------------------
5067						# _analyze_code
5068						#
5069						# Purpose: Analyse a method's source code using
5070						# pattern matching to infer parameter
5071						# names, types, constraints, defaults,
5072						# and optionality. Orchestrates all
5073						# per-parameter code analysis helpers.
5074						#
5075						# Entry: $code - method body source string.
5076						# $method - method hashref (used for
5077						# constructor-specific logic
5078						# when extracting parameters
5079						# from @_ patterns).
5080						#
5081						# Exit: Returns a hashref of parameter name
5082						# to parameter spec hashref, with as
5083						# much type and constraint information
5084						# as could be inferred from the code.
5085						#
5086						# Side effects: Logs progress and warnings to stdout
5087						# when verbose is set.
5088						#
5089						# Notes: Analysis is capped at max_parameters
5090						# to prevent runaway processing on
5091						# pathological methods. Falls back to
5092						# classic @_ extraction if signature
5093						# extraction found no parameters.
5094						# --------------------------------------------------
5095						sub _analyze_code {
5096	334			334	1995	my ($self, $code, $method) = @_;
5097
5098	334				248	my %params;
5099
5100						# Safety check - limit parameter analysis to prevent runaway processing
5101	334				281	my $param_count = 0;
5102
5103						# Extract parameter names from various signature styles
5104	334				515	$self->_extract_parameters_from_signature(\%params, $code);
5105
5106						# Params::Get: get_params('key', \@_) passes the param name as a string,
5107						# not as a $var in the signature, so run this unconditionally as a second
5108						# pass after the early-returning signature parsers have finished.
5109	334	100			470	if($code =~ /Params::Get/) {
5110	2				4	my $pos = scalar keys %params;
5111	2				6	while($code =~ /get_params\s\(\s['"](\w+)['"]/g) {
5112	2				2	my $name = $1;
5113	2	50			2	next if $name =~ /^(self\|class\|pkg\|proto\|klass)$/i;
5114	2		50		8	$params{$name} //= { _source => 'code', position => $pos++ };
5115	2				3	$self->_log(" CODE: Found Params::Get parameter '$name'");
5116						}
5117						}
5118
5119	334				588	$self->_extract_defaults_from_code(\%params, $code, $method);
5120
5121						# Infer types from defaults
5122	334				388	foreach my $param (keys %params) {
5123	227	100	100		365	if ($params{$param}{_default} && !$params{$param}{type}) {
5124	20				21	my $default = $params{$param}{_default};
5125	20	100 100			28	if (ref($default) eq 'HASH') {
5126	2				1	$params{$param}{type} = 'hashref';
5127	2				3	$self->_log(" CODE: $param type inferred as hashref from default");
5128						} elsif (ref($default) eq 'ARRAY') {
5129	1				1	$params{$param}{type} = 'arrayref';
5130	1				2	$self->_log(" CODE: $param type inferred as arrayref from default");
5131						}
5132						}
5133						}
5134
5135	334	50 50			664	if($code =~ /(?:croak\|die)$.$\s+if\s$\sscalar\(\@_$\s<\s(\d+)\s\)/s) {
5136	0				0	my $required_count = $1;
5137	0 0				0 0	my @param_names = sort { $params{$a}{position} <=> $params{$b}{position} } keys %params;
5138	0				0	for my $i (0 .. $required_count-1) {
5139	0				0	$params{$param_names[$i]}{optional} = 0;
5140	0				0	$self->_log(" CODE: $param_names[$i] marked required due to croak scalar check");
5141						}
5142						} elsif ($code =~ /(?:croak\|die)$.$\s+if\s$\sscalar\(\@_$\s==\s0\s\)/s) {
5143	0				0	foreach my $param (keys %params) {
5144	0				0	$params{$param}{optional} = 0;
5145	0				0	$self->_log(" CODE: $param: all parameters are required due to 'scalar(@_) == 0' check");
5146						}
5147						}
5148
5149						# Analyze each parameter (with safety limit)
5150	334				336	foreach my $param (keys %params) {
5151	227	50			357	if ($param_count++ > $self->{max_parameters}) {
5152	0				0	$self->_log(" WARNING: Max parameters ($self->{max_parameters}) exceeded, skipping remaining");
5153	0				0	last;
5154						}
5155
5156	227				220	my $p = \$params{$param};
5157
5158	227				398	$self->_analyze_parameter_type($p, $param, $code);
5159	227				537	$self->_analyze_parameter_constraints($p, $param, $code);
5160	227				517	$self->_analyze_parameter_validation($p, $param, $code);
5161	227				399	$self->_analyze_advanced_types($p, $param, $code);
5162
5163						# Defined checks
5164	227	100			3113	if ($code =~ /defined\s$\s\$$param\s*$/) {
5165	1				2	$$p->{optional} = 0;
5166	1				2	$self->_log(" CODE: $param is required (defined check)");
5167						}
5168
5169						# Determine optional/required and numeric type from code
5170	227	100 100 50			13456	if ($code =~ /\s\$$param\s(?:\/\/\|\\|\\|)=/) {
5171						# e.g. $var //= 5; or $var \|\|= 5;
5172	8				11	$$p->{optional} = 1;
5173	8				17	$self->_log(" CODE: $param is optional (default value assigned in code)");
5174						} elsif ($code =~ /\s\$$param\s(?:[\+\-\\%]\|\/(?!\/)\|(?:\+\+)\|(?:--)\|(?:[\+\-\\%]=\|\/(?!\/)=)\|\+\$\|\$[+-])/ ) {
5175						# Covers arithmetic usage:
5176						# $x + $param, $param++, $param--, $x += $param, $x -= $param, etc.
5177	42				73	$$p->{optional} = 0;
5178	42		50		83	$$p->{type} //= 'number';
5179	42				82	$self->_log(" CODE: $param is required (used in arithmetic context)");
5180						} elsif ($code =~ /\$\b$param\b\s(?:\+0\|\1)/) {
5181						# Forces numeric context, e.g., "$param + 0" or "$param * 1"
5182	0				0	$$p->{optional} = 0;
5183	0		0		0	$$p->{type} //= 'number';
5184	0				0	$self->_log(" CODE: $param is required (numeric context)");
5185						}
5186
5187						# Required parameter checks (undef causes error)
5188
5189						# Style 1: block form
5190	227	50			7009	if ($code =~ /if\s$\s!\sdefined\s\(\s\$$param\s$\s\)\s\{([^}]+)\}/s) {
5191	0				0	my $block = $1;
5192	0	0			0	if ($block =~ /\b(croak\|die\|confess)\b/) {
5193	0				0	$$p->{optional} = 0;
5194	0				0	$self->_log(" CODE: $param is required (undef causes error)");
5195						}
5196						}
5197
5198						# Style 2: postfix unless
5199	227	50			7554	if ($code =~ /\b(croak\|die\|confess)\b[^;]\bunless\s+defined\s$\s\$$param\s$/) {
5200	0				0	$$p->{optional} = 0;
5201	0				0	$self->_log(" CODE: $param is required (postfix undef check)");
5202						}
5203
5204						# Exists checks for hash keys
5205	227	50			2999	if ($code =~ /exists\s$\s\$$param\s*$/) {
5206	0				0	$$p->{type} = 'hashkey';
5207	0				0	$self->_log(" CODE: $param is a hash key");
5208						}
5209
5210						# Scalar context for arrays
5211	227	50			3081	if ($code =~ /scalar\s$\s\@?\$$param\s*$/) {
5212	0				0	$$p->{type} = 'array';
5213	0				0	$self->_log(" CODE: $param used in scalar context (array)");
5214						}
5215
5216	227				374	$self->_extract_error_constraints($p, $param, $code);
5217						}
5218
5219	334				413	return \%params;
5220						}
5221
5222						# --------------------------------------------------
5223						# _analyze_parameter_type
5224						#
5225						# Purpose: Infer the type of a single parameter
5226						# from ref() checks, isa() calls,
5227						# bless patterns, array/hash operations,
5228						# and numeric operator usage in the
5229						# method body.
5230						#
5231						# Entry: $p_ref - reference to the parameter
5232						# hashref (modified in place
5233						# via the referenced hash).
5234						# $param - parameter name string.
5235						# $code - method body source string.
5236						#
5237						# Exit: Returns nothing. Modifies the
5238						# referenced parameter hashref.
5239						#
5240						# Side effects: Logs detections to stdout when
5241						# verbose is set.
5242						# --------------------------------------------------
5243						sub _analyze_parameter_type {
5244	231			231	312	my ($self, $p_ref, $param, $code) = @_;
5245	231				222	my $p = $$p_ref;
5246
5247						# Type inference from ref() checks
5248	231	100 100 100			18858	if ($code =~ /ref\s$\s\$$param\s$\seq\s*['"](ARRAY\|HASH\|SCALAR)['"]/gi) {
5249	6				9	my $reftype = lc($1);
5250	6	50 100			17	$p->{type} = $reftype eq 'array' ? 'arrayref' :
5251						$reftype eq 'hash' ? 'hashref' :
5252						'scalar';
5253	6				11	$self->_log(" CODE: $param is $p->{type} (ref check)");
5254						}
5255						# ISA checks for objects
5256						elsif ($code =~ /\$$param\s->\sisa\s$\s['"]([^'"]+)['"]\s*$/i) {
5257	3				5	$p->{type} = 'object';
5258	3				6	$p->{isa} = $1;
5259	3				9	$self->_log(" CODE: $param is object of class $1");
5260						}
5261						# Blessed references
5262						elsif ($code =~ /bless\s+.*\$$param/) {
5263	5				7	$p->{type} = 'object';
5264	5				10	$self->_log(" CODE: $param is blessed object");
5265						}
5266						# Array/hash operations
5267	231	100			484	if (!$p->{type}) {
5268	198	50 100	67 33		8138	if ($code =~ /\@\{\s\$$param\s\}/ \|\| $code =~ /push\s\(\s\@?\$$param/) {
5269	0				0	$p->{type} = 'arrayref';
5270						} elsif ($code =~ /\%\{\s\$$param\s\}/ \|\| $code =~ /\$$param\s->\s\{/) {
5271	2				6	$p->{type} = 'hashref';
5272						}
5273						}
5274
5275						# Infer type from the default value if type is unknown
5276	231	100	100		609	if (!$p->{type} && exists $p->{_default}) {
5277	22				19	my $default = $p->{_default};
5278	22	50 50			36	if (ref($default) eq 'HASH') {
5279	0				0	$p->{type} = 'hashref';
5280	0				0	$self->_log(" CODE: $param type inferred as hashref from default");
5281						} elsif (ref($default) eq 'ARRAY') {
5282	0				0	$p->{type} = 'arrayref';
5283	0				0	$self->_log(" CODE: $param type inferred as arrayref from default");
5284						}
5285						}
5286
5287						# ------------------------------------------------------------
5288						# Heuristic numeric inference (low confidence)
5289						# ------------------------------------------------------------
5290	231	100			301	if (!$p->{type}) {
5291						# An explicit looks_like_number($param) check is a direct
5292						# numeric-type assertion by the author, stronger evidence than
5293						# incidental arithmetic adjacency (e.g. $param is only ever
5294						# used inside a defined-or default before the arithmetic, so
5295						# the arithmetic-operator check below never sees $param itself
5296						# next to an operator).
5297	196	100 100 100	100 60		15402	if ($code =~ /\blooks_like_number\s$\s\$$param\s*$/) {
5298	2				3	$p->{type} = 'number';
5299	2				3	$p->{_type_confidence} = 'heuristic';
5300	2				3	$self->_log(" CODE: $param inferred as number (looks_like_number check)");
5301						}
5302						# Numeric operators: + - * / % **
5303						# Use \/(?!\/) to exclude // (defined-or) from matching as division.
5304						elsif (
5305						$code =~ /\$$param\s(?:[\+\-\\%]\|\/(?!\/))/ \|\|
5306						$code =~ /(?:[\+\-\\%]\|\/(?!\/))\s\$$param/ \|\|
5307						$code =~ /\bint\s$\s\$$param\s*$/ \|\|
5308						$code =~ /\babs\s$\s\$$param\s*$/
5309						) {
5310	55				103	$p->{type} = 'number';
5311	55				67	$p->{_type_confidence} = 'heuristic';
5312	55				108	$self->_log(" CODE: $param inferred as number (numeric operator)");
5313						}
5314						# Numeric comparison
5315						elsif (
5316						$code =~ /\$$param\s*(?:==\|!=\|<=\|>=\|<\|>)/ \|\|
5317						$code =~ /(?:==\|!=\|<=\|>=\|<\|>)\s*\$$param/
5318						) {
5319	21				35	$p->{type} = 'number';
5320	21				27	$p->{_type_confidence} = 'heuristic';
5321	21				112	$self->_log(" CODE: $param inferred as number (numeric comparison)");
5322						}
5323						}
5324						}
5325
5326						# --------------------------------------------------
5327						# _analyze_advanced_types
5328						#
5329						# Purpose: Apply enhanced type detection to a
5330						# single parameter, checking for
5331						# DateTime objects, file handles,
5332						# coderefs, and enum-like constraints
5333						# beyond what basic type inference
5334						# can determine.
5335						#
5336						# Entry: $p_ref - reference to the parameter
5337						# hashref (modified in place
5338						# via the referenced hash).
5339						# $param - the parameter name string.
5340						# $code - method body source string.
5341						#
5342						# Exit: Returns nothing. Modifies the
5343						# referenced parameter hashref in place.
5344						#
5345						# Side effects: Logs detections to stdout when
5346						# verbose is set.
5347						#
5348						# Notes: Delegates to four specialised
5349						# detectors: _detect_datetime_type,
5350						# _detect_filehandle_type,
5351						# _detect_coderef_type, and
5352						# _detect_enum_type. Each detector
5353						# returns early on first match so
5354						# detectors are implicitly prioritised
5355						# in that order.
5356						# --------------------------------------------------
5357						sub _analyze_advanced_types {
5358	228			228	1808	my ($self, $p_ref, $param, $code) = @_;
5359
5360						# Dereference once to get the hash reference
5361	228				182	my $p = $$p_ref;
5362
5363						# Now pass the dereferenced hash to the detection methods
5364	228				369	$self->_detect_datetime_type($p, $param, $code);
5365	228				461	$self->_detect_filehandle_type($p, $param, $code);
5366	228				467	$self->_detect_coderef_type($p, $param, $code);
5367	228				357	$self->_detect_enum_type($p, $param, $code);
5368						}
5369
5370						# --------------------------------------------------
5371						# _detect_datetime_type
5372						#
5373						# Purpose: Detect DateTime objects, Time::Piece
5374						# objects, date strings, ISO 8601
5375						# strings, and UNIX timestamps by
5376						# analysing code patterns involving
5377						# the parameter.
5378						#
5379						# Entry: $p - parameter hashref (modified
5380						# in place).
5381						# $param - parameter name string.
5382						# $code - method body source string.
5383						#
5384						# Exit: Returns nothing. Modifies $p in place,
5385						# setting type, isa, semantic, min,
5386						# matches, and/or format keys.
5387						# Returns immediately on first match.
5388						#
5389						# Side effects: Logs detections to stdout when
5390						# verbose is set.
5391						# --------------------------------------------------
5392						sub _detect_datetime_type {
5393	229			229	251	my ($self, $p, $param, $code) = @_;
5394
5395						# Validate param is just a simple word
5396	229	50	33		656	return unless defined $param && $param =~ /^\w+$/;
5397
5398						# DateTime object detection via isa/UNIVERSAL checks
5399	229	100			7030	if ($code =~ /\$$param\s->\sisa\s$\s['"]DateTime['"]\s*$/i) {
5400	2				4	$p->{type} = 'object';
5401	2				2	$p->{isa} = 'DateTime';
5402	2				3	$p->{semantic} = 'datetime_object';
5403	2				5	$self->_log(" ADVANCED: $param is DateTime object");
5404	2				3	return;
5405						}
5406
5407						# Check for DateTime method calls
5408	227	100			4115	if ($code =~ /\$$param\s->\s(ymd\|dmy\|mdy\|hms\|iso8601\|epoch\|strftime)/) {
5409	1				2	$p->{type} = 'object';
5410	1				2	$p->{isa} = 'DateTime';
5411	1				2	$p->{semantic} = 'datetime_object';
5412	1				2	$self->_log(" ADVANCED: $param uses DateTime methods");
5413	1				1	return;
5414						}
5415
5416						# Time::Piece detection
5417	226	50	33		9337	if ($code =~ /\$$param\s->\sisa\s$\s['"]Time::Piece['"]\s*$/i \|\|
5418						$code =~ /\$$param\s->\s(strftime\|epoch\|year\|mon\|mday)/) {
5419	0				0	$p->{type} = 'object';
5420	0				0	$p->{isa} = 'Time::Piece';
5421	0				0	$p->{semantic} = 'timepiece_object';
5422	0				0	$self->_log(" ADVANCED: $param is Time::Piece object");
5423	0				0	return;
5424						}
5425
5426						# String date/time patterns via regex matching
5427	226	100			2608	if ($code =~ /\$$param\s=~\s\/.?\\d\{4\}.?\\d\{2\}.*?\\d\{2\}/) {
5428	1				2	$p->{type} = 'string';
5429	1				2	$p->{semantic} = 'date_string';
5430	1				2	$p->{format} = 'YYYY-MM-DD or similar';
5431	1				2	$self->_log(" ADVANCED: $param validated as date string pattern");
5432	1				2	return;
5433						}
5434
5435						# ISO 8601 date pattern
5436	225	100			2649	if ($code =~ /\$$param\s=~\s\/.?[Tt].?[Zz].*?\//) {
5437	1				1	$p->{type} = 'string';
5438	1				2	$p->{semantic} = 'iso8601_string';
5439	1				1	$p->{matches} = '/^\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}Z?$/';
5440	1				3	$self->_log(" ADVANCED: $param validated as ISO 8601 datetime");
5441	1				1	return;
5442						}
5443
5444						# UNIX timestamp detection (numeric with specific range)
5445	224	50	50		8404	if ($code =~ /\$$param\s>\s\d{9,}/ \|\| # UNIX timestamps are 10+ digits
5446						$code =~ /time$\s$\s-\s*\$$param/ \|\|
5447						$code =~ /\$$param\s-\stime$\s*$/) {
5448	2				3	$p->{type} = 'integer';
5449	2				4	$p->{semantic} = 'unix_timestamp';
5450	2				3	$p->{min} = 0;
5451	2				4	$self->_log(" ADVANCED: $param appears to be UNIX timestamp");
5452	2				4	return;
5453						}
5454
5455						# Date parsing with strptime or similar
5456	222	50	33		7574	if ($code =~ /strptime\s\(\s\$$param/ \|\|
5457						$code =~ /DateTime::Format::\w+\s->\sparse_datetime\s\(\s\$$param/) {
5458	0				0	$p->{type} = 'string';
5459	0				0	$p->{semantic} = 'datetime_parseable';
5460	0				0	$self->_log(" ADVANCED: $param is parsed as datetime");
5461	0				0	return;
5462						}
5463						}
5464
5465						# --------------------------------------------------
5466						# _detect_filehandle_type
5467						#
5468						# Purpose: Detect file handle parameters and
5469						# file path string parameters by
5470						# analysing I/O operations, file test
5471						# operators, and path manipulation
5472						# patterns involving the parameter.
5473						#
5474						# Entry: $p - parameter hashref (modified
5475						# in place).
5476						# $param - parameter name string.
5477						# $code - method body source string.
5478						#
5479						# Exit: Returns nothing. Modifies $p in place,
5480						# setting type, isa, and semantic keys.
5481						# Returns immediately on first match.
5482						#
5483						# Side effects: Logs detections to stdout when
5484						# verbose is set.
5485						# --------------------------------------------------
5486						sub _detect_filehandle_type {
5487	229			229	275	my ($self, $p, $param, $code) = @_;
5488
5489	229	50	33		587	return unless defined $param && $param =~ /^\w+$/;
5490
5491						# File handle operations
5492	229	100			5408	if ($code =~ /(?:open\|close\|read\|print\|say\|sysread\|syswrite)\s\(?\s\$$param/) {
5493	2				4	$p->{type} = 'object';
5494	2				2	$p->{isa} = 'IO::Handle';
5495	2				3	$p->{semantic} = 'filehandle';
5496	2				6	$self->_log(" ADVANCED: $param is a file handle");
5497	2				4	return;
5498						}
5499
5500						# Filehandle-specific operations
5501	227	100			4087	if ($code =~ /\$$param\s->\s(readline\|getline\|print\|say\|close\|flush\|autoflush)/) {
5502	1				1	$p->{type} = 'object';
5503	1				2	$p->{isa} = 'IO::Handle';
5504	1				2	$p->{semantic} = 'filehandle';
5505	1				3	$self->_log(" ADVANCED: $param uses filehandle methods");
5506	1				2	return;
5507						}
5508
5509						# File test operators
5510	226	100			2776	if ($code =~ /(?:-[frwxoOeszlpSbctugkTBMAC])\s+\$$param/) {
5511	3				6	$p->{type} = 'string';
5512	3				5	$p->{semantic} = 'filepath';
5513	3				8	$self->_log(" ADVANCED: $param is tested as file path");
5514	3				6	return;
5515						}
5516
5517						# File::Spec operations or path manipulation
5518	223	50	33		8398	if ($code =~ /File::(?:Spec\|Basename)::\w+\s\(\s\$$param/ \|\|
5519						$code =~ /(?:basename\|dirname\|fileparse)\s\(\s\$$param/) {
5520	0				0	$p->{type} = 'string';
5521	0				0	$p->{semantic} = 'filepath';
5522	0				0	$self->_log(" ADVANCED: $param manipulated as file path");
5523	0				0	return;
5524						}
5525
5526						# Path validation patterns
5527						# Only match a literal path assigned or defaulted to this variable
5528	223	50	67		471	if(defined $p->{_default} && $p->{_default} =~ m{^([A-Za-z]:\\\|/\|\./\|\.\./)}) {
5529	0				0	$p->{type} = 'string';
5530	0				0	$p->{semantic} = 'filepath';
5531	0				0	$self->_log(" ADVANCED: $param default looks like a path");
5532	0				0	return;
5533						}
5534
5535						# IO::File detection
5536	223	50	33		9181	if ($code =~ /\$$param\s->\sisa\s$\s['"]IO::File['"]\s*$/ \|\|
5537						$code =~ /IO::File\s->\snew\s\(\s\$$param/) {
5538	0				0	$p->{type} = 'object';
5539	0				0	$p->{isa} = 'IO::File';
5540	0				0	$p->{semantic} = 'filehandle';
5541	0				0	$self->_log(" ADVANCED: $param is IO::File object");
5542	0				0	return;
5543						}
5544						}
5545
5546						# --------------------------------------------------
5547						# _detect_coderef_type
5548						#
5549						# Purpose: Detect coderef and callback parameters
5550						# by analysing ref() checks, invocation
5551						# patterns, and parameter naming
5552						# conventions.
5553						#
5554						# Entry: $p - parameter hashref (modified
5555						# in place).
5556						# $param - parameter name string.
5557						# $code - method body source string.
5558						#
5559						# Exit: Returns nothing. Modifies $p in place,
5560						# setting type and semantic keys.
5561						# Returns immediately on first match.
5562						#
5563						# Side effects: Logs detections to stdout when
5564						# verbose is set.
5565						# --------------------------------------------------
5566						sub _detect_coderef_type {
5567	230			230	282	my ($self, $p, $param, $code) = @_;
5568
5569	230	50	33		552	return unless defined $param && $param =~ /^\w+$/;
5570
5571						# ref() check for CODE
5572	230	100			6618	if ($code =~ /ref\s$\s\$$param\s$\seq\s*['"]CODE['"]/i) {
5573	2				4	$p->{type} = 'coderef';
5574	2				26	$p->{semantic} = 'callback';
5575	2				5	$self->_log(" ADVANCED: $param is coderef (ref check)");
5576	2				2	return;
5577						}
5578
5579						# Invocation as coderef - note the escaped @ in \@_
5580	228	50	50		8548	if ($code =~ /\$$param\s->\s\(/ \|\|
5581						$code =~ /\$$param\s->\s$\s\@_\s$/ \|\|
5582						$code =~ /&\s\{\s\$$param\s*\}/) {
5583	2				4	$p->{type} = 'coderef';
5584	2				2	$p->{semantic} = 'callback';
5585	2				6	$self->_log(" ADVANCED: $param invoked as coderef");
5586	2				2	return;
5587						}
5588
5589						# Parameter name suggests callback
5590	226	100			476	if ($param =~ /^(?:callback\|cb\|handler\|sub\|code\|fn\|func\|on_\w+)$/i) {
5591	2				4	$p->{type} = 'coderef';
5592	2				1	$p->{semantic} = 'callback';
5593	2				4	$self->_log(" ADVANCED: $param name suggests coderef");
5594	2				4	return;
5595						}
5596
5597						# Blessed coderef (unusual but valid)
5598	224	50	33		3119	if ($code =~ /blessed\s$\s\$$param\s*$/ &&
5599						$code =~ /ref\s$\s\$$param\s$\seq\s*['"]CODE['"]/i) {
5600	0				0	$p->{type} = 'object';
5601	0				0	$p->{isa} = 'blessed_coderef';
5602	0				0	$p->{semantic} = 'callback';
5603	0				0	$self->_log(" ADVANCED: $param is blessed coderef");
5604	0				0	return;
5605						}
5606						}
5607
5608						# --------------------------------------------------
5609						# _detect_enum_type
5610						#
5611						# Purpose: Detect enum-like parameters whose
5612						# valid values are a fixed set, by
5613						# analysing validation patterns
5614						# including regex alternations, hash
5615						# lookups, grep checks, given/when,
5616						# if/elsif chains, and smart match.
5617						#
5618						# Entry: $p - parameter hashref (modified
5619						# in place).
5620						# $param - parameter name string.
5621						# $code - method body source string.
5622						#
5623						# Exit: Returns nothing. Modifies $p in place,
5624						# setting type, enum, and semantic keys.
5625						# Returns immediately on first match.
5626						#
5627						# Side effects: Logs detections to stdout when
5628						# verbose is set.
5629						#
5630						# Notes: Requires at least 3 if/elsif branches
5631						# for pattern 5 to avoid false positives
5632						# from ordinary conditional code.
5633						# --------------------------------------------------
5634						sub _detect_enum_type {
5635	230			230	278	my ($self, $p, $param, $code) = @_;
5636
5637	230	50	33		545	return unless defined $param && $param =~ /^\w+$/;
5638
5639						# Pattern 1: die/croak unless value is in list
5640						# die 'Invalid status' unless $status =~ /^(active\|inactive\|pending)$/;
5641	230	100			3627	if ($code =~ /unless\s+\$$param\s=~\s\/\^?$([^)]+)$/) {
5642	4				8	my $values = $1;
5643	4				8	my @enum_values = split(/\\|/, $values);
5644	4	100			10	$p->{type} = 'string' unless $p->{type};
5645	4				7	$p->{enum} = \@enum_values;
5646	4				7	$p->{semantic} = 'enum';
5647	4				14	$self->_log(" ADVANCED: $param is enum with values: " . join(', ', @enum_values));
5648	4				6	return;
5649						}
5650
5651						# Pattern 2: Hash lookup for validation
5652						# my %valid = map { $_ => 1 } qw(red green blue);
5653						# die unless $valid{$param};
5654	226	100			338	if ($code =~ /\%(\w+)\s=.?qw\s*[$\[<{]([^)\]>}]+)[$\]>}]/) {
5655	3				6	my $hash_name = $1;
5656	3				3	my $values_str = $2;
5657	3	100	67		54	if (defined $values_str && $code =~ /\$$hash_name\s\{\s\$$param\s*\}/) {
5658	2				4	my @enum_values = split(/\s+/, $values_str);
5659	2	50			4	$p->{type} = 'string' unless $p->{type};
5660	2				4	$p->{enum} = \@enum_values;
5661	2				2	$p->{semantic} = 'enum';
5662	2				8	$self->_log(" ADVANCED: $param validated via hash lookup: " . join(', ', @enum_values));
5663	2				4	return;
5664						}
5665						}
5666
5667						# Pattern 3: Array grep validation
5668						# die unless grep { $_ eq $param } qw(foo bar baz);
5669	224	100			5624	if ($code =~ /grep\s\{[^}]\$$param[^}]\}\sqw\s*[$\[<{]([^)\]>}]+)[$\]>}]/) {
5670	1				2	my $values_str = $1;
5671	1				2	my @enum_values = split(/\s+/, $values_str);
5672	1	50			2	$p->{type} = 'string' unless $p->{type};
5673	1				2	$p->{enum} = \@enum_values;
5674	1				1	$p->{semantic} = 'enum';
5675	1				4	$self->_log(" ADVANCED: $param validated via grep: " . join(', ', @enum_values));
5676	1				1	return;
5677						}
5678
5679						# Pattern 4: Given/when (Perl 5.10+)
5680	223	100			3021	if ($code =~ /given\s$\s\$$param\s*$/) {
5681	1				1	my @enum_values;
5682	1				7	while ($code =~ /when\s$\s['"]([^'"]+)['"]\s*$/g) {
5683	2				5	push @enum_values, $1;
5684						}
5685	1	50			3	if (@enum_values >= 2) {
5686	1	50			4	$p->{type} = 'string' unless $p->{type};
5687	1				3	$p->{enum} = \@enum_values;
5688	1				2	$p->{semantic} = 'enum';
5689	1				3	$self->_log(" ADVANCED: $param has enum values from given/when: " .
5690						join(', ', @enum_values));
5691	1				3	return;
5692						}
5693						}
5694
5695						# Pattern 5: Multiple if/elsif checking specific values
5696	222				211	my @if_values;
5697	222				6309	while ($code =~ /if\s$\s\$$param\seq\s['"]([^'"]+)['"]\s*$/g) {
5698	10				31	push @if_values, $1;
5699						}
5700	222				6328	while ($code =~ /elsif\s$\s\$$param\seq\s['"]([^'"]+)['"]\s*$/g) {
5701	7				17	push @if_values, $1;
5702						}
5703	222	100			332	if (@if_values >= 3) {
5704	3	50			9	$p->{type} = 'string' unless $p->{type};
5705	3				4	$p->{enum} = \@if_values;
5706	3				5	$p->{semantic} = 'enum';
5707	3				11	$self->_log(" ADVANCED: $param appears to be enum from if/elsif: " .
5708						join(', ', @if_values));
5709	3				6	return;
5710						}
5711
5712						# Pattern 6: Smart match (~~) with array
5713	219	50	33		7596	if ($code =~ /\$$param\s~~\s\[([^\]]+)\]/ \|\|
5714						$code =~ /\$$param\s~~\sqw\s*[$\[<{]([^)\]>}]+)[$\]>}]/) {
5715	0				0	my $values_str = $1;
5716	0				0	my @enum_values;
5717	0	0			0	if ($values_str =~ /['"]/) {
5718	0				0	@enum_values = $values_str =~ /['"](.*?)['"]/g;
5719						} else {
5720	0				0	@enum_values = split(/\s+/, $values_str);
5721						}
5722	0	0			0	if (@enum_values) {
5723	0	0			0	$p->{type} = 'string' unless $p->{type};
5724	0				0	$p->{enum} = \@enum_values;
5725	0				0	$p->{semantic} = 'enum';
5726	0				0	$self->_log(" ADVANCED: $param validated with smart match: " .
5727						join(', ', @enum_values));
5728	0				0	return;
5729						}
5730						}
5731						}
5732
5733						# --------------------------------------------------
5734						# _extract_error_constraints
5735						#
5736						# Purpose: Extract invalid-value constraints and
5737						# error messages from die/croak patterns
5738						# referencing a specific parameter, and
5739						# infer numeric bounds from comparisons
5740						# with literals.
5741						#
5742						# Entry: $p_ref - reference to the parameter
5743						# hashref (modified in place).
5744						# $param - parameter name string.
5745						# $code - method body source string.
5746						#
5747						# Exit: Returns nothing. May add _invalid,
5748						# _errors, min, and/or max to the
5749						# referenced parameter hashref.
5750						#
5751						# Side effects: Logs detections to stdout when
5752						# verbose is set.
5753						# --------------------------------------------------
5754						sub _extract_error_constraints {
5755	230			230	283	my ($self, $p, $param, $code) = @_;
5756
5757						# Look for die/croak/confess with a condition involving this param
5758	230				509	while ($code =~ /
5759						(?:die\|croak\|confess) # error call
5760						\s*
5761						(?:
5762						["']([^"']+)["'] # captured error message
5763						\|
5764						q[qw]?\s*[$\[]([^)\]]+)[$\]] # q(), qq(), qw()
5765						)?
5766						\s*
5767						if\s+
5768						(.+?) # condition
5769						\s*;
5770						/gsx) {
5771
5772	37		67		75	my $message = $1 \|\| $2;
5773	37				40	my $condition = $3;
5774
5775						# Only keep conditions that reference this parameter
5776	37	100			187	next unless $condition =~ /\$$param\b/;
5777
5778						# Initialize storage
5779	24		100		66	$$p->{_invalid} \|\|= [];
5780	24		100		54	$$p->{_errors} \|\|= [];
5781
5782						# Normalize condition (strip surrounding parens)
5783	24				50	$condition =~ s/^$\|$$//g;
5784	24				57	$condition =~ s/\s+/ /g;
5785
5786						# Try to extract a meaningful invalid constraint
5787	24				19	my $constraint;
5788
5789						# Examples:
5790						# $age <= 0
5791						# $x eq ''
5792						# length($s) < 3
5793	24	100 100 50			1040	if ($condition =~ /\$$param\s([!<>=]=?\|eq\|ne\|lt\|gt\|le\|ge)\s(.+)/) {
5794	8				16	$constraint = "$1 $2";
5795						}
5796						elsif ($condition =~ /length\s$\s\$$param\s$\s([<>=!]+)\s*(\d+)/) {
5797	1				2	$constraint = "length $1 $2";
5798						}
5799						elsif ($condition =~ /\$$param\s==\s0/) {
5800	0				0	$constraint = '== 0';
5801						}
5802
5803						# Store results
5804	24 9	100			34 12	push @{ $$p->{_invalid} }, $constraint if $constraint;
5805	24 19	100			28 21	push @{ $$p->{_errors} }, $message if defined $message;
5806
5807	24	100			59	$self->_log(
5808						" ERROR: $param invalid when [$condition]" .
5809						(defined $message ? " => '$message'" : '')
5810						);
5811						}
5812
5813						# Numeric comparison with literal
5814	230	100			4460	if ($code =~ /\b\Q$param\E\s(<=\|<\|>=\|>)\s(-?\d+)/) {
5815	19				37	my ($op, $num) = ($1, $2);
5816
5817						# Mark required
5818	19				30	$$p->{optional} = 0;
5819
5820	19	100 100 100 50			77	if ($op eq '<=') {
5821	1				2	$$p->{min} = $num + 1;
5822						} elsif ($op eq '<') {
5823	5				8	$$p->{min} = $num;
5824						} elsif ($op eq '>=') {
5825	1				2	$$p->{max} = $num - 1;
5826						} elsif ($op eq '>') {
5827	12				17	$$p->{max} = $num;
5828						}
5829
5830	19				42	$self->_log(" ERROR: $param normalized constraint from '$op $num'");
5831						}
5832						}
5833
5834						# --------------------------------------------------
5835						# _extract_parameters_from_signature
5836						#
5837						# Purpose: Extract parameter names and positions
5838						# from a method's signature, trying
5839						# modern Perl subroutine signatures
5840						# first and falling back to traditional
5841						# @_ extraction styles.
5842						#
5843						# Entry: $params - hashref to populate with
5844						# parameter specs (modified
5845						# in place).
5846						# $code - method body source string.
5847						#
5848						# Exit: Returns nothing. Populates $params.
5849						#
5850						# Side effects: Logs detections to stdout when
5851						# verbose is set.
5852						#
5853						# Notes: Three traditional styles are
5854						# supported: (1) my ($self, ...) = @_,
5855						# (2) my $self = shift; my $x = shift,
5856						# (3) my $x = $_[N]. $self and $class
5857						# are always excluded from the returned
5858						# parameters.
5859						# --------------------------------------------------
5860						sub _extract_parameters_from_signature {
5861	674			674	642	my ($self, $params, $code) = @_;
5862
5863						# Modern Style: Subroutine signatures with attributes
5864						# Handle multi-line signatures
5865						# sub foo :attr1 :attr2(val) (
5866						# $self,
5867						# $x :Type,
5868						# $y = default
5869						# ) { }
5870
5871						# Try to match signature after attributes
5872						# Look for the parameter list - it's the last (...) before the opening brace
5873						# that contains sigils ($, %, @)
5874	674	100			1773	if ($code =~ /sub\s+\w+\s(?::\w+(?:$[^)]$)?\s)$((?:[^()]\|\([^)]$))\)\s*\{/s) {
5875	28				34	my $potential_sig = $1;
5876
5877						# Check if this looks like parameters (has sigils)
5878	28	100			47	if ($potential_sig =~ /[\$\%\@]/) {
5879	24				40	$self->_log(" SIG: Found modern signature: ($potential_sig)");
5880	24				40	$self->_parse_modern_signature($params, $potential_sig);
5881	24				25	return;
5882						}
5883						}
5884
5885						# Direct-index style: my $self = $_[0]; my $arg = $_[1]; ...
5886						# Must be checked before Style 1 to avoid matching @_ inside closures
5887						# defined in the body of a method that uses this style.
5888	650	100			801	if($code =~ /my\s+\$(?:self\|class)\s=\s\$_\[0\]/) {
5889	22				22	my $pos = 0;
5890	22				55	while($code =~ /my\s+\$(\w+)\s=\s\$_\[(\d+)\]/g) {
5891	24				30	my $name = $1;
5892	24	100			63	next if $name =~ /^(self\|class\|pkg\|proto\|klass)$/i;
5893	2		50		6	$params->{$name} //= { _source => 'code', optional => 1, position => $pos++ };
5894	2				6	$self->_log(" CODE: Found direct-index parameter '\$$name' at \$_[$2]");
5895						}
5896	22				28	return;
5897						}
5898
5899						# Traditional Style 1: my ($self, $arg1, $arg2) = @_;
5900	628	100 100			1248	if ($code =~ /my\s$\s([^)]+)$\s=\s\@_/s) {
5901	339				396	my $sig = $1;
5902	339				260	my $pos = 0;
5903
5904	339				661	while ($sig =~ /\$(\w+)/g) {
5905	710				585	my $name = $1;
5906
5907	710	100			1169	next if $name =~ /^(self\|class\|pkg\|proto\|klass)$/i;
5908
5909	395		50		1110	$params->{$name} //= {
5910						_source => 'code',
5911						optional => 1,
5912						};
5913
5914	395	50			669	$params->{$name}{position} = $pos unless exists $params->{$name}{position};
5915
5916	395				470	$pos++;
5917						}
5918	339				371	return;
5919						} elsif ($code =~ /my\s+\$self\s=\sshift/) {
5920						# Traditional Style 2: my $self = shift; my $arg1 = shift;
5921	32				27	my @shifts;
5922	32				79	while ($code =~ /my\s+\$(\w+)\s=\sshift/g) {
5923	39				74	push @shifts, $1;
5924						}
5925	32	50	33		106	shift @shifts if @shifts && $shifts[0] =~ /^(self\|class\|pkg\|proto\|klass)$/i;
5926	32				32	my $pos = 0;
5927	32				33	foreach my $param (@shifts) {
5928	7		50		24	$params->{$param} \|\|= { _source => 'code', optional => 1, position => $pos++ };
5929						}
5930	32				42	return;
5931						}
5932
5933						# Traditional Style 3: Function parameters (no $self)
5934	257	50			259	if ($code =~ /my\s$\s([^)]+)$\s=\s\@_/s) {
5935	0				0	my $sig = $1;
5936	0				0	my @param_names = $sig =~ /\$(\w+)/g;
5937	0				0	my $pos = 0;
5938	0				0	foreach my $param (@param_names) {
5939	0	0			0	next if $param =~ /^(self\|class\|pkg\|proto\|klass)$/i;
5940	0		0		0	$params->{$param} \|\|= { _source => 'code', optional => 1, position => $pos++ };
5941						}
5942						}
5943
5944						# De-duplicate
5945	257				154	my %seen;
5946	257				295	foreach my $param (keys %$params) {
5947	0	0			0	if ($seen{$param}++) {
5948	0				0	$self->_log(" WARNING: Duplicate parameter '$param' found");
5949						}
5950						}
5951						}
5952
5953						# --------------------------------------------------
5954						# _parse_modern_signature
5955						#
5956						# Purpose: Parse a Perl 5.20+ subroutine
5957						# signature string into individual
5958						# parameter specs, respecting nested
5959						# structures when splitting on commas.
5960						#
5961						# Entry: $params - hashref to populate
5962						# (modified in place).
5963						# $sig - signature string with outer
5964						# parentheses already removed.
5965						#
5966						# Exit: Returns nothing. Populates $params
5967						# via _parse_signature_parameter.
5968						#
5969						# Side effects: Logs parsing details to stdout when
5970						# verbose is set.
5971						# --------------------------------------------------
5972						sub _parse_modern_signature {
5973	26			26	3319	my ($self, $params, $sig) = @_;
5974
5975	26				41	$self->_log(" DEBUG: Parsing signature: [$sig]");
5976
5977						# Split signature by commas, but respect nested structures (e.g. a
5978						# default value containing a hashref/arrayref literal)
5979	26				1192	require Text::Balanced;
5980	26				12943	my @parts;
5981	26				29	my $current = '';
5982	26				27	my $rest = $sig;
5983
5984	26				27	while (length $rest) {
5985	743	100			608	if (substr($rest, 0, 1) =~ /[(\[{]/) {
5986						# extract_bracketed advances $rest past the extracted block
5987						# in place, so $rest must not be re-truncated afterwards
5988	3				7	my $extracted = Text::Balanced::extract_bracketed($rest, '(){}[]');
5989	3	50			381	last unless defined $extracted; # Unbalanced brackets
5990	3				5	$current .= $extracted;
5991	3				4	next;
5992						}
5993	740	100			639	if (substr($rest, 0, 1) eq ',') {
5994	47				37	push @parts, $current;
5995	47				37	$current = '';
5996	47				33	$rest = substr($rest, 1);
5997	47				36	next;
5998						}
5999	693				423	$current .= substr($rest, 0, 1);
6000	693				535	$rest = substr($rest, 1);
6001						}
6002	26	50			47	push @parts, $current if $current =~ /\S/;
6003
6004	26				21	my $position = 0;
6005
6006	26				24	foreach my $part (@parts) {
6007	73				172	$part =~ s/^\s+\|\s+$//g;
6008
6009						# Skip empty parts
6010	73	50			71	next unless $part;
6011
6012						# Parse different parameter types
6013	73				83	my $param_info = $self->_parse_signature_parameter($part, $position);
6014
6015	73	50			70	if ($param_info) {
6016	73				54	my $name = $param_info->{name};
6017
6018						# Skip self/class
6019	73	100			103	if ($name =~ /^(self\|class\|pkg\|proto\|klass)$/i) {
6020	18				27	next;
6021						}
6022
6023	55				61	$params->{$name} = $param_info;
6024						$self->_log(" SIG: $name has position $position" .
6025						($param_info->{optional} ? ' (optional)' : '') .
6026	55	100 100			134	($param_info->{_default} ? ", default: $param_info->{_default}" : ''));
6027	55				68	$position++;
6028						}
6029						}
6030						}
6031
6032						# --------------------------------------------------
6033						# _parse_signature_parameter
6034						#
6035						# Purpose: Parse a single parameter declaration
6036						# from a modern Perl signature, handling
6037						# type constraints, default values,
6038						# plain scalars, and slurpy array/hash
6039						# parameters.
6040						#
6041						# Entry: $part - a single parameter string
6042						# (one comma-separated
6043						# element from the signature).
6044						# $position - zero-based position index
6045						# of this parameter.
6046						#
6047						# Exit: Returns a parameter info hashref on
6048						# success, or undef if the string does
6049						# not match any known pattern.
6050						#
6051						# Side effects: None.
6052						#
6053						# Notes: Six patterns are tried in order:
6054						# (1) :Type with default,
6055						# (2) :Type without default,
6056						# (3) default without type,
6057						# (4) plain $name,
6058						# (5) slurpy @name,
6059						# (6) slurpy %name.
6060						# --------------------------------------------------
6061						sub _parse_signature_parameter {
6062	86			86	5503	my ($self, $part, $position) = @_;
6063
6064	86				121	my %info = (
6065						_source => 'signature',
6066						position => $position,
6067						optional => 0,
6068						);
6069
6070						# Pattern 1: Type constraint WITH default: $name :Type = default
6071	86	100 100 100 100 100 100			277	if ($part =~ /^\$(\w+)\s:\s(\w+)\s=\s(.+)$/s) {
6072	7				12	my ($name, $constraint, $default) = ($1, $2, $3);
6073	7				10	$default =~ s/^\s+\|\s+$//g;
6074
6075	7				8	$info{name} = $name;
6076	7				6	$info{optional} = 1;
6077	7				11	$info{_default} = $self->_clean_default_value($default, 1);
6078
6079						# Apply type constraint
6080	7	100 100 50 0 0 0			19	if ($constraint =~ /^(Int\|Integer)$/i) {
6081	2				4	$info{type} = 'integer';
6082						} elsif ($constraint =~ /^(Num\|Number)$/i) {
6083	3				5	$info{type} = 'number';
6084						} elsif ($constraint =~ /^(Str\|String)$/i) {
6085	2				2	$info{type} = 'string';
6086						} elsif ($constraint =~ /^(Bool\|Boolean)$/i) {
6087	0				0	$info{type} = 'boolean';
6088						} elsif ($constraint =~ /^(Array\|ArrayRef)$/i) {
6089	0				0	$info{type} = 'arrayref';
6090						} elsif ($constraint =~ /^(Hash\|HashRef)$/i) {
6091	0				0	$info{type} = 'hashref';
6092						} else {
6093	0				0	$info{type} = 'object';
6094	0				0	$info{isa} = $constraint;
6095						}
6096
6097	7				7	return \%info;
6098						} elsif ($part =~ /^\$(\w+)\s:\s(\w+)\s*$/s) {
6099						# Pattern 2: Type constraint WITHOUT default: $name :Type
6100	14				21	my ($name, $constraint) = ($1, $2);
6101	14				18	$info{name} = $name;
6102	14				14	$info{optional} = 0;
6103
6104						# Apply type constraint (same as above)
6105	14	100 100 100 100 100 50			41	if ($constraint =~ /^(Int\|Integer)$/i) {
6106	4				7	$info{type} = 'integer';
6107						} elsif ($constraint =~ /^(Num\|Number)$/i) {
6108	2				2	$info{type} = 'number';
6109						} elsif ($constraint =~ /^(Str\|String)$/i) {
6110	2				2	$info{type} = 'string';
6111						} elsif ($constraint =~ /^(Bool\|Boolean)$/i) {
6112	2				3	$info{type} = 'boolean';
6113						} elsif ($constraint =~ /^(Array\|ArrayRef)$/i) {
6114	2				2	$info{type} = 'arrayref';
6115						} elsif ($constraint =~ /^(Hash\|HashRef)$/i) {
6116	0				0	$info{type} = 'hashref';
6117						} else {
6118	2				2	$info{type} = 'object';
6119	2				1	$info{isa} = $constraint;
6120						}
6121
6122	14				17	return \%info;
6123						} elsif ($part =~ /^\$(\w+)\s=\s(.+)$/s) {
6124						# Pattern 3: Default WITHOUT type: $name = default
6125	16				23	my ($name, $default) = ($1, $2);
6126	16				26	$default =~ s/^\s+\|\s+$//g;
6127
6128	16				17	$info{name} = $name;
6129	16				13	$info{optional} = 1;
6130	16				22	$info{_default} = $self->_clean_default_value($default, 1);
6131	16	50			47	$info{type} = $self->_infer_type_from_default($info{_default}) if $self->can('_infer_type_from_default');
6132
6133	16				20	return \%info;
6134						}
6135
6136						# Pattern 4: Plain parameter: $name
6137						elsif ($part =~ /^\$(\w+)$/s) {
6138	39				47	$info{name} = $1;
6139	39				34	$info{optional} = 0;
6140	39				41	return \%info;
6141						}
6142
6143						# Pattern 5: Array parameter: @name
6144						elsif ($part =~ /^\@(\w+)$/s) {
6145	4				5	$info{name} = $1;
6146	4				5	$info{type} = 'array';
6147	4				7	$info{slurpy} = 1;
6148	4				4	$info{optional} = 1;
6149	4				6	return \%info;
6150						}
6151
6152						# Pattern 6: Hash parameter: %name
6153						elsif ($part =~ /^\%(\w+)$/s) {
6154	4				6	$info{name} = $1;
6155	4				5	$info{type} = 'hash';
6156	4				4	$info{slurpy} = 1;
6157	4				4	$info{optional} = 1;
6158	4				5	return \%info;
6159						}
6160
6161	2				4	return undef;
6162						}
6163
6164						# --------------------------------------------------
6165						# _infer_type_from_default
6166						#
6167						# Purpose: Infer a parameter type from its
6168						# default value when no explicit type
6169						# annotation is available.
6170						#
6171						# Entry: $default - the cleaned default value
6172						# scalar, hashref, or
6173						# arrayref. May be undef.
6174						#
6175						# Exit: Returns a type string ('hashref',
6176						# 'arrayref', 'integer', 'number',
6177						# 'boolean', 'string'), or undef if
6178						# $default is undef.
6179						#
6180						# Side effects: None.
6181						# --------------------------------------------------
6182						sub _infer_type_from_default {
6183	33			33	48	my ($self, $default) = @_;
6184
6185	33	100			37	return undef unless defined $default;
6186
6187	29	100 100 100 100 50	33		100	if (ref($default) eq 'HASH') {
6188	2				4	return 'hashref';
6189						} elsif (ref($default) eq 'ARRAY') {
6190	2				5	return 'arrayref';
6191						} elsif ($default =~ /^-?\d+$/) {
6192	16				24	return 'integer';
6193						} elsif ($default =~ /^-?\d+\.\d+$/) {
6194	2				4	return 'number';
6195						} elsif ($default eq '1' \|\| $default eq '0') {
6196	0				0	return 'boolean';
6197						} else {
6198	7				12	return 'string';
6199						}
6200						}
6201
6202						# --------------------------------------------------
6203						# _extract_subroutine_attributes
6204						#
6205						# Purpose: Extract Perl subroutine attributes
6206						# (e.g. :lvalue, :method, :Returns(Int))
6207						# from a method's source string.
6208						#
6209						# Entry: $code - method body source string.
6210						#
6211						# Exit: Returns a hashref of attribute name
6212						# to value (1 for flag-only attributes,
6213						# the attribute argument string for
6214						# attributes with values).
6215						# Returns an empty hashref if no
6216						# attributes are found.
6217						#
6218						# Side effects: Logs detections to stdout when
6219						# verbose is set.
6220						# --------------------------------------------------
6221						sub _extract_subroutine_attributes {
6222	339			339	1932	my ($self, $code) = @_;
6223
6224	339				255	my %attributes;
6225
6226						# Extract all attributes from the sub declaration
6227						# Attributes are :name or :name(value) between sub name and either ( or {
6228						# Pattern: sub name ATTRIBUTES ( params ) { }
6229						# or: sub name ATTRIBUTES { }
6230
6231						# First, find the attributes section (everything between sub name and ( or { )
6232	339				280	my $attr_section = '';
6233
6234	339	100			661	if($code =~ /sub\s+\w+\s+((?::\w+(?:$[^)]$)?\s)+)/s) {
6235	9				14	$attr_section = $1;
6236						}
6237
6238						# Parse individual attributes from the section
6239	339	100			410	if($attr_section) {
6240	9				21	while($attr_section =~ /:(\w+)(?:$([^)]*)$)?/g) {
6241	11				17	my ($name, $value) = ($1, $2);
6242
6243	11	100	67		20	if (defined $value && $value ne '') {
6244	5				9	$attributes{$name} = $value;
6245	5				11	$self->_log(" ATTR: Found attribute :$name($value)");
6246						} else {
6247	6				7	$attributes{$name} = 1;
6248	6				8	$self->_log(" ATTR: Found attribute :$name");
6249						}
6250						}
6251						}
6252
6253						# Process common attributes
6254	339	100			426	if ($attributes{Returns}) {
6255	4				5	my $return_type = $attributes{Returns};
6256	4	50			7	if ($return_type ne '1') { # Only log if it's an actual type, not just the flag
6257	4				5	$self->_log(" ATTR: Method declares return type: $return_type");
6258						}
6259						}
6260
6261	339	100			396	if ($attributes{lvalue}) {
6262	4				7	$self->_log(" ATTR: Method is lvalue (can be assigned to)");
6263						}
6264
6265	339	100			368	if ($attributes{method}) {
6266	2				2	$self->_log(' ATTR: Method explicitly marked as :method');
6267						}
6268
6269	339				363	return \%attributes;
6270						}
6271
6272						# --------------------------------------------------
6273						# _analyze_postfix_dereferencing
6274						#
6275						# Purpose: Detect usage of Perl 5.20+ postfix
6276						# dereferencing syntax in a method body
6277						# and record which dereference forms
6278						# are used.
6279						#
6280						# Entry: $code - method body source string.
6281						#
6282						# Exit: Returns a hashref whose keys are
6283						# dereference form names (array_deref,
6284						# hash_deref, scalar_deref, code_deref,
6285						# array_slice, hash_slice) with value 1
6286						# when detected.
6287						# Returns an empty hashref if no
6288						# postfix dereferencing is found.
6289						#
6290						# Side effects: Logs detections to stdout when
6291						# verbose is set.
6292						# --------------------------------------------------
6293						sub _analyze_postfix_dereferencing {
6294	341			341	1318	my ($self, $code) = @_;
6295
6296	341				283	my %derefs;
6297
6298						# Array dereference: $ref->@*
6299	341	100			693	if ($code =~ /\$\w+\s->\s\@\*/) {
6300	4				6	$derefs{array_deref} = 1;
6301	4				5	$self->_log(" MODERN: Uses postfix array dereferencing (->@*)");
6302						}
6303
6304						# Hash dereference: $ref->%*
6305	341	100			625	if ($code =~ /\$\w+\s->\s\%\*/) {
6306	3				5	$derefs{hash_deref} = 1;
6307	3				5	$self->_log(" MODERN: Uses postfix hash dereferencing (->%*)");
6308						}
6309
6310						# Scalar dereference: $ref->$*
6311	341	100			657	if ($code =~ /\$\w+\s->\s\$\*/) {
6312	2				2	$derefs{scalar_deref} = 1;
6313	2				3	$self->_log(' MODERN: Uses postfix scalar dereferencing (->$*)');
6314						}
6315
6316						# Code dereference: $ref->&*
6317	341	100			625	if ($code =~ /\$\w+\s->\s\&\*/) {
6318	1				2	$derefs{code_deref} = 1;
6319	1				1	$self->_log(" MODERN: Uses postfix code dereferencing (->&*)");
6320						}
6321
6322						# Array element: $ref->@[0,2,4]
6323	341	100			577	if ($code =~ /\$\w+\s->\s\@\[/) {
6324	2				4	$derefs{array_slice} = 1;
6325	2				3	$self->_log(" MODERN: Uses postfix array slice (->@[...])");
6326						}
6327
6328						# Hash element: $ref->%{key1,key2}
6329	341	100			571	if ($code =~ /\$\w+\s->\s\%\{/) {
6330	2				3	$derefs{hash_slice} = 1;
6331	2				4	$self->_log(" MODERN: Uses postfix hash slice (->%{...})");
6332						}
6333
6334	341				341	return \%derefs;
6335						}
6336
6337						# --------------------------------------------------
6338						# _extract_field_declarations
6339						#
6340						# Purpose: Extract Perl 5.38 field declarations
6341						# from a class body or method source
6342						# string, capturing field names,
6343						# :param attributes, default values,
6344						# and :isa type constraints.
6345						#
6346						# Entry: $code - source string potentially
6347						# containing 'field $name ...'
6348						# declarations.
6349						#
6350						# Exit: Returns a hashref of field name to
6351						# field_info hashref. Returns an empty
6352						# hashref if no field declarations
6353						# are found.
6354						#
6355						# Side effects: Logs detections to stdout when
6356						# verbose is set.
6357						# --------------------------------------------------
6358						sub _extract_field_declarations {
6359	342			342	2354	my ($self, $code) = @_;
6360
6361	342				252	my %fields;
6362
6363						# Pattern: field $name :param;
6364						# Pattern: field $name :param(name);
6365						# Pattern: field $name = default;
6366						# More lenient pattern to catch various formats
6367	342				566	while ($code =~ /^\sfield\s+\$(\w+)\s([^;]*);/gm) {
6368	12				18	my ($name, $modifiers) = ($1, $2);
6369
6370	12				23	$self->_log(" FIELD: Found field \$$name with modifiers: [$modifiers]");
6371
6372	12				15	my %field_info = (
6373						name => $name,
6374						_source => 'field'
6375						);
6376
6377						# Check for :param attribute
6378	12	100			27	if ($modifiers =~ /:param(?:$([^)]+)$)?/) {
6379	11				9	$field_info{is_param} = 1;
6380
6381	11	100			18	if (defined $1) {
6382						# Explicit parameter name
6383	2				2	$field_info{param_name} = $1;
6384						} else {
6385						# Implicit - field name is param name
6386	9				8	$field_info{param_name} = $name;
6387						}
6388
6389	11				15	$self->_log(" FIELD: $name maps to parameter: $field_info{param_name}");
6390						}
6391
6392						# Check for default value - must come before type constraint check
6393	12	100			20	if ($modifiers =~ /=\s*([^:;]+)(?::\|;\|$)/) {
6394	4				7	my $default = $1;
6395	4				4	$default =~ s/\s+$//;
6396	4				8	$field_info{_default} = $self->_clean_default_value($default, 1);
6397	4				25	$field_info{optional} = 1;
6398	4	50			12	$self->_log(" FIELD: $name has default: " . (defined $field_info{_default} ? $field_info{_default} : 'undef'));
6399						}
6400
6401						# Check for type constraints
6402	12	100			17	if ($modifiers =~ /:isa$([^)]+)$/) {
6403	3				5	$field_info{isa} = $1;
6404	3				4	$field_info{type} = 'object';
6405	3				9	$self->_log(" FIELD: $name has type constraint: $1");
6406						}
6407
6408	12				23	$fields{$name} = \%field_info;
6409						}
6410
6411	342				323	return \%fields;
6412						}
6413
6414						# --------------------------------------------------
6415						# _merge_field_declarations
6416						#
6417						# Purpose: Integrate Perl 5.38 field declarations
6418						# that carry the :param attribute into
6419						# the code parameter hashref, so they
6420						# appear as constructor parameters in
6421						# the generated schema.
6422						#
6423						# Entry: $params - hashref of parameters
6424						# extracted from code analysis
6425						# (modified in place).
6426						# $fields - hashref of field declarations
6427						# as returned by
6428						# _extract_field_declarations.
6429						#
6430						# Exit: Returns nothing. Modifies $params
6431						# in place.
6432						#
6433						# Side effects: Logs merges to stdout when verbose
6434						# is set.
6435						#
6436						# Notes: Only fields with is_param => 1 are
6437						# merged. The param_name key in the
6438						# field (which may differ from the
6439						# field name if :param(name) was used)
6440						# determines the parameter key.
6441						# --------------------------------------------------
6442						sub _merge_field_declarations {
6443	6			6	31	my ($self, $params, $fields) = @_;
6444
6445	6				9	foreach my $field_name (keys %$fields) {
6446	11				7	my $field = $fields->{$field_name};
6447
6448						# Only process fields that are parameters
6449	11	100			13	next unless $field->{is_param};
6450
6451	9				8	my $param_name = $field->{param_name};
6452
6453						# Create or update parameter info
6454	9		50		19	$params->{$param_name} \|\|= {};
6455	9				8	my $p = $params->{$param_name};
6456
6457						# Merge field information into parameter
6458	9	50			14	$p->{_source} = 'field' unless $p->{_source};
6459	9	100			12	$p->{field_name} = $field_name if $field_name ne $param_name;
6460
6461	9	100			10	if ($field->{_default}) {
6462	3				4	$p->{_default} = $field->{_default};
6463	3				3	$p->{optional} = 1;
6464						}
6465
6466	9	100			9	if ($field->{isa}) {
6467	2				3	$p->{isa} = $field->{isa};
6468	2				3	$p->{type} = 'object';
6469						}
6470
6471	9				11	$self->_log(" MERGED: Field $field_name -> parameter $param_name");
6472						}
6473						}
6474
6475						# --------------------------------------------------
6476						# _extract_defaults_from_code
6477						#
6478						# Purpose: Scan a method body for default value
6479						# assignment patterns and populate the
6480						# optional and _default fields of
6481						# known parameters.
6482						#
6483						# Entry: $params - hashref of parameters
6484						# (modified in place).
6485						# $code - method body source string.
6486						# $method - method hashref, used for
6487						# constructor-specific
6488						# exclusions of $class and
6489						# $self.
6490						#
6491						# Exit: Returns nothing. Modifies $params
6492						# in place.
6493						#
6494						# Side effects: Logs detections to stdout when
6495						# verbose is set.
6496						#
6497						# Notes: Eight default patterns are tried.
6498						# Only parameters already present in
6499						# $params are updated â€” this method
6500						# does not add new parameters.
6501						# Falls back to extracting all @_
6502						# assignments if $params is empty
6503						# after the main pass.
6504						# --------------------------------------------------
6505						sub _extract_defaults_from_code {
6506	339			339	381	my ($self, $params, $code, $method) = @_;
6507
6508						# Pattern 1: my $param = value;
6509	339				676	while ($code =~ /my\s+\$(\w+)\s=\s([^;]+);/g) {
6510	81				135	my ($param, $value) = ($1, $2);
6511	81	100			168	next unless exists $params->{$param};
6512	3	50			6	next if $value =~ /->/; # deref/method call, not a default value
6513
6514	3				7	$params->{$param}{_default} = $self->_clean_default_value($value, 1);
6515	3				4	$params->{$param}{optional} = 1;
6516	3				12	$self->_log(" CODE: $param has default: " . $self->_format_default($params->{$param}{_default}));
6517						}
6518
6519						# Pattern 2: $param = value unless defined $param;
6520	339				801	while ($code =~ /\$(\w+)\s=\s([^;]+?)\s+unless\s+(?:defined\s+)?\$\1/g) {
6521	4				8	my ($param, $value) = ($1, $2);
6522	4	50			5	next unless exists $params->{$param};
6523
6524	4				7	$params->{$param}{_default} = $self->_clean_default_value($value, 1);
6525	4				3	$params->{$param}{optional} = 1;
6526	4				8	$self->_log(" CODE: $param has default (unless): " . $self->_format_default($params->{$param}{_default}));
6527						}
6528
6529						# Pattern 3: $param = value unless $param;
6530	339				866	while ($code =~ /\$(\w+)\s=\s([^;]+?)\s+unless\s+\$\1/g) {
6531	1				2	my ($param, $value) = ($1, $2);
6532	1	50			1	next unless exists $params->{$param};
6533
6534	1				1	$params->{$param}{_default} = $self->_clean_default_value($value, 1);
6535	1				1	$params->{$param}{optional} = 1;
6536	1				2	$self->_log(" CODE: $param has default (unless): " . $self->_format_default($params->{$param}{_default}));
6537						}
6538
6539						# Pattern 4: $param = $param \|\| 'default';
6540	339				495	while ($code =~ /\$(\w+)\s=\s\$\1\s\\|\\|\s([^;]+);/g) {
6541	8				12	my ($param, $value) = ($1, $2);
6542	8	50			9	next unless exists $params->{$param};
6543
6544	8				10	$params->{$param}{_default} = $self->_clean_default_value($value, 1);
6545	8				8	$params->{$param}{optional} = 1;
6546	8				12	$self->_log(" CODE: $param has default (\|\|): " . $self->_format_default($params->{$param}{_default}));
6547						}
6548
6549						# Pattern 5: $param \|\|= 'default';
6550	339				483	while ($code =~ /\$(\w+)\s\\|\\|=\s([^;]+);/g) {
6551	3				6	my ($param, $value) = ($1, $2);
6552	3	50			6	next unless exists $params->{$param};
6553
6554	3				6	$params->{$param}{_default} = $self->_clean_default_value($value, 1);
6555	3				4	$params->{$param}{optional} = 1;
6556	3				8	$self->_log(" CODE: $param has default (\|\|=): " . $self->_format_default($params->{$param}{_default}));
6557						}
6558
6559						# Pattern 6: $param //= 'default';
6560	339				479	while ($code =~ /\$(\w+)\s\/\/=\s([^;]+);/g) {
6561	8				12	my ($param, $value) = ($1, $2);
6562	8	100			13	next unless exists $params->{$param}; # Using -> because $params is a reference
6563
6564	7				9	$params->{$param}{_default} = $self->_clean_default_value($value, 1);
6565
6566	7				8	$params->{$param}{optional} = 1;
6567	7				12	$self->_log(" CODE: $param has default (//=): " . $self->_format_default($params->{$param}{_default}));
6568						}
6569
6570						# Pattern 7: $param = defined $param ? $param : 'default';
6571	339				622	while ($code =~ /\$(\w+)\s=\sdefined\s+\$\1\s\?\s\$\1\s:\s([^;]+);/g) {
6572	4				5	my ($param, $value) = ($1, $2);
6573
6574						# Create param entry if it doesn't exist
6575	4		50		6	$params->{$param} \|\|= {};
6576
6577	4				4	my $cleaned = $self->_clean_default_value($value, 1);
6578
6579	4				5	$params->{$param}{_default} = $cleaned;
6580	4				4	$params->{$param}{optional} = 1;
6581	4				5	$self->_log(" CODE: $param has default (ternary): " . $self->_format_default($params->{$param}{_default}));
6582						}
6583
6584						# Pattern 8: $param = $args{param} \|\| 'default';
6585	339				507	while ($code =~ /\$(\w+)\s=\s\$args\{['"]?\w+['"]?\}\s\\|\\|\s([^;]+);/g) {
6586	0				0	my ($param, $value) = ($1, $2);
6587	0	0			0	next unless exists $params->{$param};
6588
6589	0				0	$params->{$param}{_default} = $self->_clean_default_value($value, 1);
6590	0				0	$params->{$param}{optional} = 1;
6591	0				0	$self->_log(" CODE: $param has default (from args): " . $self->_format_default($params->{$param}{_default}));
6592						}
6593
6594						# Pattern for non-empty hashref
6595	339				492	while ($code =~ /\$(\w+)\s\\|\\|=\s\{[^}]+\}/gs) {
6596	1				1	my $param = $1;
6597	1	50			2	next unless exists $params->{$param};
6598
6599						# Return empty hashref as placeholder (can't evaluate complex hashrefs)
6600	1				4	$params->{$param}{_default} = {};
6601	1				1	$params->{$param}{optional} = 1;
6602	1				1	$self->_log(" CODE: $param has hashref default (\|\|=)");
6603						}
6604
6605						# Fallback: extract parameters from classic Perl body styles
6606						# Only run if signature extraction found nothing AND the code does not use
6607						# the direct-index ($_[0]) style â€” that style is used for no-param methods
6608						# whose empty %params would otherwise trigger this fallback and pick up
6609						# my (...) = @_ from inner closures as if they were method params.
6610						# TODO: On constructors, use $class to help to determine the output type
6611	339	100	100		252	if (!keys %{$params} && $code !~ /my\s+\$(?:self\|class\|pkg\|proto\|klass)\s=\s\$_\[0\]/) {
6612	169				131	my $position = 0;
6613
6614						# Style 1: my ($a, $b) = @_;
6615	169				263	while ($code =~ /my\s$\s([^)]+)\s$\s=\s*\@_/g) {
6616	30				79	my @vars = $1 =~ /\$(\w+)/g;
6617	30				57	foreach my $var (@vars) {
6618	30	50	33		94	if(($position == 0) && ($var =~ /^(self\|class\|pkg\|proto\|klass)$/i)) {
6619						# Invocant â€” skip it
6620	30				50	delete $params->{$var};
6621						} else {
6622	0		0		0	$params->{$var} \|\|= { position => $position++ };
6623	0				0	$self->_log(" CODE: $var extracted from \@_ list assignment");
6624						}
6625						}
6626						}
6627
6628						# Style 2: my $x = shift;
6629	169				238	while ($code =~ /my\s+\$(\w+)\s=\sshift\b/g) {
6630	15				18	my $var = $1;
6631	15	100	67		52	if(($position == 0) && ($var =~ /^(self\|class\|pkg\|proto\|klass)$/i)) {
6632						# Invocant â€” skip it
6633	14				19	delete $params->{$var};
6634						} else {
6635	1		50		3	$params->{$var} \|\|= { position => $position++ };
6636	1				3	$self->_log(" CODE: $var is extracted from shift");
6637						}
6638						}
6639
6640						# Style 3: my $x = $_[0];
6641	169				258	while ($code =~ /my\s+\$(\w+)\s=\s\$_\[(\d+)\]/g) {
6642	0				0	my ($var, $index) = ($1, $2);
6643	0	0	0		0	if(($index > 0) \|\| ($var !~ /^(self\|class\|pkg\|proto\|klass)$/i)) {
6644	0		0		0	$params->{$var} \|\|= { position => $index };
6645	0				0	$self->_log(" CODE: $var is extracted from \$_\[$index\]");
6646						}
6647						}
6648						}
6649						}
6650
6651						# --------------------------------------------------
6652						# _format_default
6653						#
6654						# Purpose: Format a default value for display
6655						# in verbose log output.
6656						#
6657						# Entry: $default - the default value to
6658						# format. May be undef,
6659						# a scalar, a hashref, or
6660						# an arrayref.
6661						#
6662						# Exit: Returns a display string: 'undef'
6663						# for undef, 'HASH ref' / 'ARRAY ref'
6664						# for references, or the value itself
6665						# for scalars.
6666						#
6667						# Side effects: None.
6668						# --------------------------------------------------
6669						sub _format_default {
6670	35			35	36	my ($self, $default) = @_;
6671	35	100			42	return 'undef' unless defined $default;
6672	32	100			34	return ref($default) . ' ref' if ref($default);
6673	27				42	return $default;
6674						}
6675
6676						# --------------------------------------------------
6677						# _module_constants
6678						#
6679						# Purpose: Build and cache a hash of numeric
6680						# constant values declared in the target
6681						# module source, covering both Readonly
6682						# lexicals and 'use constant' barewords.
6683						# Used by _analyze_parameter_constraints
6684						# to resolve right-hand sides like
6685						# $MIN_NAME_LEN that are not literals.
6686						#
6687						# Entry: None (uses $self->{_document}).
6688						#
6689						# Exit: Returns a hashref { NAME => value }.
6690						# Returns {} if the PPI document is not
6691						# yet loaded.
6692						#
6693						# Side effects: Caches result in $self->{_constants}.
6694						# --------------------------------------------------
6695						sub _module_constants {
6696	6			6	7	my ($self) = @_;
6697	6	100			12	return $self->{_constants} if exists $self->{_constants};
6698
6699	2				3	my %c;
6700	2				3	my $doc = $self->{_document};
6701	2	50			6	unless ($doc) {
6702	0				0	$self->{_constants} = \%c;
6703	0				0	return \%c;
6704						}
6705
6706	2				8	my $src = $doc->serialize();
6707
6708						# Readonly my $CONST => numeric_value;
6709	2				5171	while ($src =~ /Readonly\s+(?:my\|our)\s+\$(\w+)\s=>\s([+-]?\d+(?:\.\d+)?)/g) {
6710	10				31	$c{$1} = $2;
6711						}
6712
6713						# use constant CONST => numeric_value;
6714	2				18	while ($src =~ /use\s+constant\s+(\w+)\s=>\s([+-]?\d+(?:\.\d+)?)/g) {
6715	0				0	$c{$1} = $2;
6716						}
6717
6718	2				6	$self->{_constants} = \%c;
6719	2				5	return \%c;
6720						}
6721
6722						# --------------------------------------------------
6723						# _analyze_parameter_constraints
6724						#
6725						# Purpose: Infer min, max, and regex match
6726						# constraints for a single parameter
6727						# from length checks, numeric
6728						# comparisons, and regex match
6729						# patterns in the method body.
6730						#
6731						# Entry: $p_ref - reference to the parameter
6732						# hashref (modified in place).
6733						# $param - parameter name string.
6734						# $code - method body source string.
6735						#
6736						# Exit: Returns nothing. Modifies the
6737						# referenced parameter hashref.
6738						#
6739						# Side effects: Logs detections to stdout when
6740						# verbose is set.
6741						#
6742						# Notes: Numeric comparisons that appear
6743						# inside die/croak guard conditions
6744						# are excluded to avoid inferring
6745						# invalid-input ranges as valid
6746						# constraints.
6747						# --------------------------------------------------
6748						sub _analyze_parameter_constraints {
6749	230			230	295	my ($self, $p_ref, $param, $code) = @_;
6750	230				195	my $p = $$p_ref;
6751
6752						# Do not treat comparisons inside die/croak/confess as valid constraints
6753	230				175	my $guarded = 0;
6754	230	100			5017	if ($code =~ /(die\|croak\|confess)\b[^{;]\bif\b[^{;]\$$param\b/s) {
6755	24				20	$guarded = 1;
6756						}
6757
6758						# Length checks for strings â€” literal numeric RHS
6759	230	100			5639	if ($code =~ /length\s$\s\$$param\s$\s([<>]=?)\s*(\d+)/) {
6760	4				9	my ($op, $val) = ($1, $2);
6761	4		50		13	$p->{type} \|\|= 'string';
6762	4	100 50 100 50			11	if ($op eq '<') {
6763	2				3	$p->{max} = $val - 1;
6764						} elsif ($op eq '<=') {
6765	0				0	$p->{max} = $val;
6766						} elsif ($op eq '>') {
6767	1				2	$p->{min} = $val + 1;
6768						} elsif ($op eq '>=') {
6769	1				2	$p->{min} = $val;
6770						}
6771	4				11	$self->_log(" CODE: $param length constraint $op $val");
6772						}
6773
6774						# Length checks for strings â€” Readonly / use-constant RHS ($CONST_NAME)
6775	230				8068	while ($code =~ /length\s$\s\$$param\s$\s([<>]=?)\s*\$(\w+)/g) {
6776	6				12	my ($op, $const) = ($1, $2);
6777	6				13	my $val = $self->_module_constants()->{$const};
6778	6	50			8	next unless defined $val;
6779	6		100		14	$p->{type} \|\|= 'string';
6780	6	50 100 50 50			17	if ($op eq '<') {
6781	0				0	$p->{max} = $val - 1;
6782						} elsif ($op eq '<=') {
6783	3				5	$p->{max} = $val;
6784						} elsif ($op eq '>') {
6785	0				0	$p->{min} = $val + 1;
6786						} elsif ($op eq '>=') {
6787	3				3	$p->{min} = $val;
6788						}
6789	6				13	$self->_log(" CODE: $param length constraint $op \$$const ($val)");
6790						}
6791
6792						# Numeric range checks (only if NOT part of error guard)
6793	230	100	100		4695	if (
6794						!$guarded
6795						&& $code =~ /\$$param\s([<>]=?)\s([+-]?(?:\d+\.?\d*\|\.\d+))/
6796						) {
6797	14				29	my ($op, $val) = ($1, $2);
6798	14	0	33		22	$p->{type} \|\|= looks_like_number($val) ? 'number' : 'integer';
6799
6800	14	100 50	67 67		79	if ($op eq '<' \|\| $op eq '<=') {
6801						# Only set max if it tightens the range
6802	2	50			3	my $max = ($op eq '<') ? $val - 1 : $val;
6803	2	50	33		8	$p->{max} = $max if !defined($p->{max}) \|\| $max < $p->{max};
6804						} elsif ($op eq '>' \|\| $op eq '>=') {
6805	12	100			22	my $min = ($op eq '>') ? $val + 1 : $val;
6806	12	50	33		34	$p->{min} = $min if !defined($p->{min}) \|\| $min > $p->{min};
6807						}
6808						}
6809
6810						# Regex pattern matching with better capture
6811	230	100			10391	if ($code =~ /\$$param\s=~\s((?:qr?\/[^\/]+\/\|\$[\w:]+\|\$\{\w+\}))/) {
6812	1				2	my $pattern = $1;
6813	1		50		3	$p->{type} \|\|= 'string';
6814
6815						# Clean up the pattern if it's a straightforward regex
6816	1	50			4	if ($pattern =~ /^qr?\/([^\/]+)\/$/) {
6817	1				2	$p->{matches} = "/$1/";
6818						} else {
6819	0				0	$p->{matches} = $pattern;
6820						}
6821	1				2	$self->_log(" CODE: $param matches pattern: $p->{matches}");
6822						}
6823						}
6824
6825						# --------------------------------------------------
6826						# _analyze_parameter_validation
6827						#
6828						# Purpose: Determine optionality and extract
6829						# default values for a single parameter
6830						# by analysing explicit required checks
6831						# (die/croak unless defined) and default
6832						# assignment patterns in the method body.
6833						#
6834						# Entry: $p_ref - reference to the parameter
6835						# hashref (modified in place).
6836						# $param - parameter name string.
6837						# $code - method body source string.
6838						#
6839						# Exit: Returns nothing. Modifies the
6840						# referenced parameter hashref.
6841						#
6842						# Side effects: Logs detections to stdout when
6843						# verbose is set.
6844						#
6845						# Notes: Explicit required checks take highest
6846						# priority and override any default
6847						# value detected earlier.
6848						# --------------------------------------------------
6849						sub _analyze_parameter_validation {
6850	231			231	298	my ($self, $p_ref, $param, $code) = @_;
6851	231				188	my $p = $$p_ref;
6852
6853						# Required/optional checks
6854	231				173	my $is_required = 0;
6855
6856						# Die/croak if not defined
6857	231	100			5938	if ($code =~ /(?:die\|croak\|confess)\s+[^;]*unless\s+(?:defined\s+)?\$$param/s) {
6858	34				36	$is_required = 1;
6859						}
6860
6861						# Extract default values with the new method
6862	231				417	my $default_value = $self->_extract_default_value($param, $code);
6863	231	100	100		355	if (defined $default_value && !exists $p->{_default}) {
6864	3				3	$p->{optional} = 1;
6865	3				5	$p->{_default} = $default_value;
6866
6867						# Try to infer type from default value if not already set
6868	3	50			3	unless ($p->{type}) {
6869	3	50 0 0 0 0	0		8	if (looks_like_number($default_value)) {
6870	3	50			6	$p->{type} = $default_value =~ /\./ ? 'number' : 'integer';
6871						} elsif (ref($default_value) eq 'ARRAY') {
6872	0				0	$p->{type} = 'arrayref';
6873						} elsif (ref($default_value) eq 'HASH') {
6874	0				0	$p->{type} = 'hashref';
6875						} elsif ($default_value eq 'undef') {
6876	0				0	$p->{type} = 'scalar'; # undef can be any scalar
6877						} elsif (defined $default_value && !ref($default_value)) {
6878	0				0	$p->{type} = 'string';
6879						}
6880						}
6881
6882	3	50			8	$self->_log(" CODE: $param has default value: " . (ref($default_value) ? ref($default_value) . ' ref' : $default_value));
6883						}
6884
6885						# Also check for simple default assignment without condition
6886						# Pattern: $param = 'value';
6887	231	100	100 100		4844	if (!$default_value && !exists $p->{_default} && $code =~ /\$$param\s=\s([^;{}]+?)(?:\s*[;}])/s) {
6888	10				16	my $assignment = $1;
6889						# Make sure it's not part of a larger expression
6890	10	100	67		88	if ($assignment !~ /\$$param/ && $assignment !~ /^shift/) {
6891	9				10	my $possible_default = $assignment;
6892	9				15	$possible_default =~ s/\s;\s$//;
6893	9				20	$possible_default = $self->_clean_default_value($possible_default);
6894	9	50			13	if (defined $possible_default) {
6895	9				15	$p->{_default} = $possible_default;
6896	9				11	$p->{optional} = 1;
6897	9				19	$self->_log(" CODE: $param has unconditional default: $possible_default");
6898						}
6899						}
6900						}
6901
6902						# Explicit required check overrides default detection
6903	231	100			450	if ($is_required) {
6904	34				56	$p->{optional} = 0;
6905	34	100			50	delete $p->{_default} if exists $p->{_default};
6906	34				76	$self->_log(" CODE: $param is required (validation check)");
6907						}
6908						}
6909
6910						# --------------------------------------------------
6911						# _merge_parameter_analyses
6912						#
6913						# Purpose: Merge parameter information from POD,
6914						# code, and signature analysis into a
6915						# single authoritative parameter hashref
6916						# for each parameter.
6917						#
6918						# Entry: $pod - hashref of parameters from POD
6919						# analysis.
6920						# $code - hashref of parameters from
6921						# code analysis.
6922						# $sig - hashref of parameters from
6923						# signature analysis (optional,
6924						# defaults to empty hashref).
6925						#
6926						# Exit: Returns a merged hashref of parameter
6927						# name to spec hashref. Each spec has
6928						# all available information combined,
6929						# with POD taking highest priority,
6930						# code second, and signature filling
6931						# remaining gaps.
6932						#
6933						# Side effects: Logs merged parameter details to
6934						# stdout when verbose is set.
6935						#
6936						# Notes: Position is determined by majority
6937						# vote across all sources, with the
6938						# lowest position winning ties. Optional
6939						# status is determined by
6940						# _determine_optional_status. Internal
6941						# _source keys are stripped from the
6942						# merged result.
6943						# --------------------------------------------------
6944						sub _merge_parameter_analyses {
6945	332			332	460	my ($self, $pod, $code, $sig) = @_;
6946
6947	332				258	my %merged;
6948
6949						# Start with all parameters from all sources
6950	332 310				554 471	my %all_params = map { $_ => 1 } (keys %$pod, keys %$code, keys %$sig);
6951
6952	332				423	foreach my $param (keys %all_params) {
6953	232				270	my $p = $merged{$param} = {};
6954
6955						# Collect position from all sources
6956	232				179	my @positions;
6957	232	100	100		441	push @positions, $pod->{$param}{position} if $pod->{$param} && defined $pod->{$param}{position};
6958	232	50	33		300	push @positions, $sig->{$param}{position} if $sig->{$param} && defined $sig->{$param}{position};
6959	232	100	100		542	push @positions, $code->{$param}{position} if $code->{$param} && defined $code->{$param}{position};
6960
6961						# Use the most common position, or lowest if tie
6962	232	100			238	if (@positions) {
6963	224				154	my %pos_count;
6964	224				439	$pos_count{$_}++ for @positions;
6965	224 0	0			307 0	my ($best_pos) = sort { $pos_count{$b} <=> $pos_count{$a} \|\| $a <=> $b } keys %pos_count;
6966	224	50			461	$p->{position} = $best_pos unless(exists($p->{position}));
6967						}
6968
6969						# POD has highest priority for type info and explicit declarations
6970	232	100			251	if ($pod->{$param}) {
6971	83 83				86 160	%$p = (%$p, %{$pod->{$param}});
6972						}
6973
6974						# Code analysis adds concrete evidence (but doesn't override POD explicit types)
6975	232	100			248	if ($code->{$param}) {
6976	227 227				169 309	foreach my $key (keys %{$code->{$param}}) {
6977	1056	100			847	next if $key eq '_source';
6978	834	100			650	next if $key eq 'position';
6979						# Formal input-spec declared this param without a type â€” author
6980						# intentionally left it unconstrained; don't let code heuristics
6981						# silently fill in a type that would cause wrong-type die tests.
6982	612	50	80		649	next if $key eq 'type' && $pod->{$param} && $pod->{$param}{_from_input_spec} && !defined $pod->{$param}{type};
6983
6984						# Only override if POD didn't provide this info or it's a stronger signal
6985	612				418	my $from_pod = exists $pod->{$param};
6986	612	100	83		708	if (!exists $p->{$key} \|\|
6987						($key eq 'type' && $from_pod && $p->{type} eq 'string' &&
6988						$code->{$param}{$key} ne 'string')) {
6989	549				533	$p->{$key} = $code->{$param}{$key};
6990						}
6991						}
6992						}
6993
6994						# Signature fills in remaining gaps
6995	232	50			267	if ($sig->{$param}) {
6996	0 0				0 0	foreach my $key (keys %{$sig->{$param}}) {
6997	0	0			0	next if $key eq '_source';
6998	0	0			0	next if $key eq 'position';
6999	0		0		0	$p->{$key} //= $sig->{$param}{$key};
7000						}
7001						}
7002
7003						# Handle optional field with better logic
7004	232				476	$self->_determine_optional_status($p, $pod->{$param}, $code->{$param});
7005
7006						# Clean up internal fields
7007	232				310	delete $p->{_source};
7008						}
7009
7010						# Debug logging
7011	332	100			423	if ($self->{verbose}) {
7012	2 1		50 50		4 5	foreach my $param (sort { ($merged{$a}{position} \|\| 999) <=> ($merged{$b}{position} \|\| 999) } keys %merged) {
7013	2				3	my $p = $merged{$param};
7014						$self->_log(" MERGED $param: " .
7015						'pos=' . ($p->{position} \|\| 'none') .
7016						", type=" . ($p->{type} \|\| 'none') .
7017	2	50	50 100		8	", optional=" . (defined($p->{optional}) ? $p->{optional} : 'undef'));
7018						}
7019						}
7020
7021	332				612	return \%merged;
7022						}
7023
7024						# --------------------------------------------------
7025						# _determine_optional_status
7026						#
7027						# Purpose: Set the optional field on a merged
7028						# parameter spec based on evidence from
7029						# POD and code analysis, with POD taking
7030						# highest priority.
7031						#
7032						# Entry: $merged_param - the merged parameter
7033						# hashref (modified in
7034						# place).
7035						# $pod_param - parameter spec from
7036						# POD analysis, or undef.
7037						# $code_param - parameter spec from
7038						# code analysis, or undef.
7039						#
7040						# Exit: Returns nothing. Sets or leaves
7041						# $merged_param->{optional}.
7042						#
7043						# Side effects: None.
7044						# --------------------------------------------------
7045						sub _determine_optional_status {
7046	238			238	1347	my ($self, $merged_param, $pod_param, $code_param) = @_;
7047
7048	238	100			282	my $pod_optional = $pod_param ? $pod_param->{optional} : undef;
7049	238	100			306	my $code_optional = $code_param ? $code_param->{optional} : undef;
7050
7051						# Explicit POD declaration wins
7052	238	100 100 100			294	if (defined $pod_optional) {
7053	23				26	$merged_param->{optional} = $pod_optional;
7054						}
7055						# Code validation evidence
7056						elsif (defined $code_optional) {
7057	203				227	$merged_param->{optional} = $code_optional;
7058						}
7059						# Default: if we have any info about the param, assume required
7060						elsif (keys %$merged_param > 0) {
7061	11				12	$merged_param->{optional} = 0;
7062						}
7063						# Otherwise leave undef (unknown)
7064						}
7065
7066
7067						# --------------------------------------------------
7068						# _calculate_input_confidence
7069						#
7070						# Purpose: Calculate a confidence score and level
7071						# for the input parameter analysis,
7072						# based on how much type, constraint,
7073						# and semantic information was inferred
7074						# for each parameter.
7075						#
7076						# Entry: $params - hashref of merged parameter
7077						# specs as produced by
7078						# _merge_parameter_analyses.
7079						#
7080						# Exit: Returns a hashref with keys:
7081						# level - one of: none,
7082						# very_low, low,
7083						# medium, high
7084						# score - numeric average
7085						# across all params
7086						# factors - arrayref of
7087						# human-readable
7088						# factor strings
7089						# per_parameter - hashref of per-
7090						# parameter score
7091						# and factor detail
7092						# Returns { level => 'none', ... } if
7093						# no parameters were found.
7094						#
7095						# Side effects: None.
7096						# --------------------------------------------------
7097						sub _calculate_input_confidence {
7098	101			101	4443	my ($self, $params) = @_;
7099
7100	101				81	my @factors; # Track all confidence factors
7101
7102	101	100			178	return { level => 'none', factors => ['No parameters found'] } unless keys %$params;
7103
7104	74				78	my $total_score = 0;
7105	74				82	my $count = 0;
7106	74				63	my %param_details; # Store per-parameter analysis
7107
7108	74				107	foreach my $param (keys %$params) {
7109	107				149	my $p = $params->{$param};
7110	107				81	my $score = 0;
7111	107				72	my @param_factors;
7112
7113						# Type information
7114	107	100			148	if ($p->{type}) {
7115	106	100 100	100		359	if ($p->{type} eq 'string' && ($p->{min} \|\| $p->{max} \|\| $p->{matches})) {
7116	9				14	$score += 25;
7117	9				12	push @param_factors, "Type: constrained string (+25)";
7118						} elsif ($p->{type} eq 'string') {
7119	23				21	$score += 10;
7120	23				31	push @param_factors, "Type: plain string (+10)";
7121						} else {
7122	74				69	$score += 30;
7123	74				140	push @param_factors, "Type: $p->{type} (+30)";
7124						}
7125						} else {
7126	1				1	push @param_factors, "No type information (-0)";
7127						}
7128
7129						# Constraints
7130	107	100			155	if (defined $p->{min}) {
7131	17				17	$score += 15;
7132	17				20	push @param_factors, 'Has min constraint (+15)';
7133						}
7134	107	100			133	if (defined $p->{max}) {
7135	14				13	$score += 15;
7136	14				19	push @param_factors, "Has max constraint (+15)";
7137						}
7138	107	100			141	if (defined $p->{optional}) {
7139	101				79	$score += 20;
7140	101				100	push @param_factors, "Optional/required explicitly defined (+20)";
7141						}
7142	107	100			123	if ($p->{matches}) {
7143	2				2	$score += 20;
7144	2				4	push @param_factors, 'Has regex pattern constraint (+20)';
7145						}
7146	107	100			134	if ($p->{isa}) {
7147	5				4	$score += 25;
7148	5				6	push @param_factors, "Specific class constraint: $p->{isa} (+25)";
7149						}
7150
7151						# Position information
7152	107	100			144	if (defined $p->{position}) {
7153	99				71	$score += 10;
7154	99				134	push @param_factors, "Position defined: $p->{position} (+10)";
7155						}
7156
7157						# Default value
7158	107	100			138	if (exists $p->{_default}) {
7159	23				14	$score += 10;
7160	23				21	push @param_factors, "Has default value (+10)";
7161						}
7162
7163						# Semantic information
7164	107	100			130	if ($p->{semantic}) {
7165	17				16	$score += 15;
7166	17				21	push @param_factors, "Semantic type: $p->{semantic} (+15)";
7167						}
7168
7169	107				194	$param_details{$param} = {
7170						score => $score,
7171						factors => \@param_factors
7172						};
7173
7174	107				92	$total_score += $score;
7175	107				100	$count++;
7176						}
7177
7178	74	50			138	my $avg = $count ? ($total_score / $count) : 0;
7179
7180						# Build summary factors
7181	74	100			206	push @factors, sprintf("Analyzed %d parameter%s", $count, $count == 1 ? '' : 's');
7182	74				391	push @factors, sprintf("Average confidence score: %.1f", $avg);
7183
7184						# Add top contributing factors
7185	74 44				133 62	my @sorted_params = sort { $param_details{$b}{score} <=> $param_details{$a}{score} } keys %param_details;
7186
7187	74	50			107	if (@sorted_params) {
7188	74				135	my $highest = $sorted_params[0];
7189	74				76	my $highest_score = $param_details{$highest}{score};
7190	74				126	push @factors, sprintf("Highest scoring parameter: \$$highest (score: %d)", $highest_score);
7191
7192	74	100			114	if (@sorted_params > 1) {
7193	23				27	my $lowest = $sorted_params[-1];
7194	23				17	my $lowest_score = $param_details{$lowest}{score};
7195	23				43	push @factors, sprintf("Lowest scoring parameter: \$$lowest (score: %d)", $lowest_score);
7196						}
7197						}
7198
7199						# Determine confidence level
7200	74				82	my $level;
7201	74	100 100 100			144	if ($avg >= $CONFIDENCE_HIGH_THRESHOLD) {
7202	54				235	$level = $LEVEL_HIGH;
7203	54				136	push @factors, "High confidence: comprehensive type and constraint information";
7204						} elsif ($avg >= $CONFIDENCE_MEDIUM_THRESHOLD) {
7205	15				84	$level = $LEVEL_MEDIUM;
7206	15				43	push @factors, "Medium confidence: some type or constraint information present";
7207						} elsif ($avg >= $CONFIDENCE_LOW_THRESHOLD) {
7208	2				20	$level = $LEVEL_LOW;
7209	2				5	push @factors, "Low confidence: minimal type information";
7210						} else {
7211	3				23	$level = $LEVEL_VERY_LOW;
7212	3				7	push @factors, "Very low confidence: little to no type information";
7213						}
7214
7215						return {
7216	74				258	level => $level,
7217						score => $avg,
7218						factors => \@factors,
7219						per_parameter => \%param_details
7220						};
7221						}
7222
7223						# --------------------------------------------------
7224						# _calculate_output_confidence
7225						#
7226						# Purpose: Calculate a confidence score and level
7227						# for the output analysis based on how
7228						# much return type, value, class,
7229						# context, and error convention
7230						# information was determined.
7231						#
7232						# Entry: $output - the output hashref as built
7233						# by _analyze_output.
7234						#
7235						# Exit: Returns a hashref with keys:
7236						# level - one of: none, very_low,
7237						# low, medium, high
7238						# score - numeric confidence score
7239						# factors - arrayref of factor strings
7240						# Returns { level => 'none', ... } if
7241						# output is empty.
7242						#
7243						# Side effects: None.
7244						# --------------------------------------------------
7245						sub _calculate_output_confidence {
7246	348			348	3520	my ($self, $output) = @_;
7247
7248	348				263	my @factors;
7249
7250	348	100			466	return { level => 'none', factors => ['No return information found'] } unless keys %$output;
7251
7252	329				291	my $score = 0;
7253
7254						# Type information
7255	329	100			380	if ($output->{type}) {
7256	321				278	$score += 30;
7257	321				471	push @factors, "Return type defined: $output->{type} (+30)";
7258						} else {
7259	8				12	push @factors, 'No return type information (-0)';
7260						}
7261
7262						# Specific value known
7263	329	100			423	if (defined $output->{value}) {
7264	28				32	$score += 30;
7265	28				45	push @factors, "Specific return value: $output->{value} (+30)";
7266						}
7267
7268						# Class information for objects
7269	329	100			373	if ($output->{isa}) {
7270	33				32	$score += 30;
7271	33				66	push @factors, "Returns specific class: $output->{isa} (+30)";
7272						}
7273
7274						# Context-aware returns
7275	329	100			383	if ($output->{_context_aware}) {
7276	4				3	$score += 20;
7277	4				3	push @factors, "Context-aware return (wantarray) (+20)";
7278
7279	4	50			6	if ($output->{_list_context}) {
7280	4				6	push @factors, " List context: $output->{_list_context}{type}";
7281						}
7282	4	100			4	if ($output->{_scalar_context}) {
7283	3				3	push @factors, " Scalar context: $output->{_scalar_context}{type}";
7284						}
7285						}
7286
7287						# Error handling information
7288	329	100			377	if ($output->{_error_return}) {
7289	17				16	$score += 15;
7290	17				25	push @factors, "Error return convention documented: $output->{_error_return} (+15)";
7291						}
7292
7293						# Success/failure pattern
7294	329	100			387	if ($output->{_success_failure_pattern}) {
7295	5				6	$score += 10;
7296	5				6	push @factors, 'Success/failure pattern detected (+10)';
7297						}
7298
7299						# Chainable methods
7300	329	100			404	if ($output->{_returns_self}) {
7301	7				7	$score += 15;
7302	7				9	push @factors, "Chainable method (fluent interface) (+15)";
7303						}
7304
7305						# Void context
7306	329	100			355	if ($output->{_void_context}) {
7307	5				4	$score += 20;
7308	5				5	push @factors, "Void context method (no meaningful return) (+20)";
7309						}
7310
7311						# Exception handling
7312	329	100	100		402	if ($output->{_error_handling} && $output->{_error_handling}{exception_handling}) {
7313	2				2	$score += 10;
7314	2				2	push @factors, 'Exception handling present (+10)';
7315						}
7316
7317	329				643	push @factors, sprintf("Total output confidence score: %d", $score);
7318
7319						# Determine confidence level
7320	329				244	my $level;
7321	329	100 100 100			736	if ($score >= $CONFIDENCE_HIGH_THRESHOLD) {
7322	63				203	$level = $LEVEL_HIGH;
7323	63				165	push @factors, "High confidence: detailed return type and behavior";
7324						} elsif ($score >= $CONFIDENCE_MEDIUM_THRESHOLD) {
7325	19				98	$level = $LEVEL_MEDIUM;
7326	19				44	push @factors, "Medium confidence: return type defined";
7327						} elsif ($score >= $CONFIDENCE_LOW_THRESHOLD) {
7328	244				1629	$level = $LEVEL_LOW;
7329	244				570	push @factors, "Low confidence: minimal return information";
7330						} else {
7331	3				19	$level = $LEVEL_VERY_LOW;
7332	3				12	push @factors, 'Very low confidence: little return information';
7333						}
7334
7335						return {
7336	329				925	level => $level,
7337						score => $score,
7338						factors => \@factors
7339						};
7340						}
7341
7342						# --------------------------------------------------
7343						# _generate_confidence_report
7344						#
7345						# Purpose: Generate a human-readable text report
7346						# of all confidence factors for a
7347						# schema, for debugging and review
7348						# purposes.
7349						#
7350						# Entry: $schema - schema hashref containing
7351						# a populated _analysis key.
7352						#
7353						# Exit: Returns a multi-line string report,
7354						# or nothing if $schema->{_analysis}
7355						# is absent.
7356						#
7357						# Side effects: None.
7358						# --------------------------------------------------
7359						sub _generate_confidence_report
7360						{
7361	3			3	17	my ($self, $schema) = @_;
7362
7363	3	100			4	return unless $schema->{_analysis};
7364
7365	2				3	my $analysis = $schema->{_analysis};
7366	2				2	my @report;
7367
7368	2		50		6	push @report, "Confidence Analysis for " . ($schema->{method_name} \|\| 'method');
7369	2				2	push @report, '=' x 60;
7370	2				2	push @report, '';
7371
7372	2				4	push @report, "Overall Confidence: " . uc($analysis->{overall_confidence});
7373	2				2	push @report, '';
7374
7375	2	50			4	if ($analysis->{confidence_factors}{input}) {
7376						push @report, (
7377						"Input Parameters:",
7378						" Confidence Level: " . uc($analysis->{input_confidence})
7379	2				4	);
7380	2 2				2 4	foreach my $factor (@{$analysis->{confidence_factors}{input}}) {
7381	2				3	push @report, " - $factor";
7382						}
7383	2				3	push @report, '';
7384						}
7385
7386	2	50			3	if ($analysis->{confidence_factors}{output}) {
7387						push @report, 'Return Value:',
7388	2				2	" Confidence Level: " . uc($analysis->{output_confidence});
7389	2 2				2 4	foreach my $factor (@{$analysis->{confidence_factors}{output}}) {
7390	2				2	push @report, " - $factor";
7391						}
7392	2				2	push @report, '';
7393						}
7394
7395	2	50			3	if ($analysis->{per_parameter_scores}) {
7396	0				0	push @report, 'Per-Parameter Analysis:';
7397	0 0				0 0	foreach my $param (sort keys %{$analysis->{per_parameter_scores}}) {
7398	0				0	my $details = $analysis->{per_parameter_scores}{$param};
7399	0				0	push @report, " \$$param (score: $details->{score}):";
7400	0 0				0 0	foreach my $factor (@{$details->{factors}}) {
7401	0				0	push @report, " - $factor";
7402						}
7403						}
7404	0				0	push @report, '';
7405						}
7406
7407	2				6	return join("\n", @report);
7408						}
7409
7410						# --------------------------------------------------
7411						# _generate_notes
7412						#
7413						# Purpose: Generate human-readable advisory notes
7414						# about parameters whose type or
7415						# optionality could not be determined,
7416						# to guide manual schema review.
7417						#
7418						# Entry: $params - hashref of merged parameter
7419						# specs.
7420						#
7421						# Exit: Returns an arrayref of note strings.
7422						# Returns an empty arrayref if all
7423						# parameters have known types and
7424						# optionality.
7425						#
7426						# Side effects: None.
7427						# --------------------------------------------------
7428						sub _generate_notes {
7429	336			336	1464	my ($self, $params) = @_;
7430
7431	336				262	my @notes;
7432
7433	336				521	foreach my $param (keys %$params) {
7434	231				205	my $p = $params->{$param};
7435
7436	231	100			296	unless ($p->{type}) {
7437	64				75	push @notes, "$param: type unknown - please review - will set to 'string' as a default";
7438						}
7439
7440	231	100			298	unless (defined $p->{optional}) {
7441	11				17	push @notes, "$param: optional status unknown";
7442						# Don't automatically set - let it be undef if we don't know
7443						}
7444						}
7445
7446	336				464	return \@notes;
7447						}
7448
7449						# --------------------------------------------------
7450						# _set_defaults
7451						#
7452						# Purpose: Apply default type values to any
7453						# parameters in a schema mode (input
7454						# or output) whose type was not set
7455						# during analysis, setting them to
7456						# 'string' as a conservative fallback.
7457						#
7458						# Entry: $schema - the schema hashref being
7459						# built by _analyze_method.
7460						# $mode - either 'input' or 'output'.
7461						#
7462						# Exit: Returns nothing. Modifies $schema in
7463						# place by setting type => 'string' on
7464						# any parameter that lacks a type, and
7465						# downgrading input confidence to 'low'.
7466						#
7467						# Side effects: Logs type defaulting to stdout when
7468						# verbose is set.
7469						#
7470						# Notes: Called after all analysis is complete
7471						# so that genuine type unknowns can be
7472						# distinguished from analysis gaps.
7473						# --------------------------------------------------
7474						sub _set_defaults {
7475	664			664	643	my ($self, $schema, $mode) = @_;
7476
7477	664				520	my $params = $schema->{$mode};
7478
7479	664				712	foreach my $param (keys %$params) {
7480	836				655	my $p = $params->{$param};
7481
7482	836	100			997	next unless(ref($p) eq 'HASH');
7483	253	100			372	unless ($p->{type}) {
7484	81				185	$self->_log(" DEBUG {$mode}{$param}: Setting to 'string' as a default");
7485	81				84	$p->{'type'} = 'string';
7486	81				118	$schema->{_confidence}{$mode}->{level} = 'low'; # Setting a default means it's a guess
7487						}
7488						}
7489						}
7490
7491						# --------------------------------------------------
7492						# _analyze_relationships
7493						#
7494						# Purpose: Detect inter-parameter relationships
7495						# in a method's source code, including
7496						# mutually exclusive parameters, required
7497						# groups, conditional requirements,
7498						# dependencies, and value-based
7499						# constraints.
7500						#
7501						# Entry: $method - method hashref containing
7502						# at minimum a 'body' key
7503						# with the source string.
7504						#
7505						# Exit: Returns an arrayref of relationship
7506						# hashrefs. Returns an empty arrayref
7507						# if no parameters or no relationships
7508						# are found.
7509						#
7510						# Side effects: Logs detections to stdout when
7511						# verbose is set.
7512						#
7513						# Notes: Parameter names are extracted via
7514						# _extract_parameters_from_signature, so
7515						# every style it supports -- my (...) =
7516						# @_, shift-style (my $x = shift), direct-
7517						# index ($_[N]), and modern signatures --
7518						# is analysed for relationships, not just
7519						# the my (...) = @_ list-assignment form.
7520						# --------------------------------------------------
7521						sub _analyze_relationships {
7522	337			337	328	my ($self, $method) = @_;
7523
7524	337				326	my $code = $method->{body};
7525	337				277	my @relationships;
7526
7527						# Extract all parameter names from the method, using the same
7528						# multi-style detection used for schema population so shift-style
7529						# and modern-signature methods get relationship analysis too
7530						my %params;
7531	337				572	$self->_extract_parameters_from_signature(\%params, $code);
7532	337 93				486 151	my @param_names = sort { $params{$a}{position} <=> $params{$b}{position} } keys %params;
7533
7534	337	100			457	return [] unless @param_names;
7535
7536						# Detect mutually exclusive parameters
7537	155 155				141 263	push @relationships, @{$self->_detect_mutually_exclusive($code, \@param_names)};
7538
7539						# Detect required groups (OR logic)
7540	155 155				144 289	push @relationships, @{$self->_detect_required_groups($code, \@param_names)};
7541
7542						# Detect conditional requirements (IF-THEN)
7543	155 155				141 256	push @relationships, @{$self->_detect_conditional_requirements($code, \@param_names)};
7544
7545						# Detect dependencies
7546	155 155				134 252	push @relationships, @{$self->_detect_dependencies($code, \@param_names)};
7547
7548						# Detect value-based constraints
7549	155 155				160 238	push @relationships, @{$self->_detect_value_constraints($code, \@param_names)};
7550
7551						# Deduplicate relationships
7552	155				280	my @unique = $self->_deduplicate_relationships(\@relationships);
7553
7554	155				357	return \@unique;
7555						}
7556
7557						# --------------------------------------------------
7558						# _deduplicate_relationships
7559						#
7560						# Purpose: Remove duplicate relationship entries
7561						# from the relationships list by
7562						# computing a canonical signature for
7563						# each relationship type.
7564						#
7565						# Entry: $relationships - arrayref of
7566						# relationship hashrefs.
7567						#
7568						# Exit: Returns a deduplicated list of
7569						# relationship hashrefs.
7570						#
7571						# Side effects: None.
7572						# --------------------------------------------------
7573						sub _deduplicate_relationships {
7574	159			159	1163	my ($self, $relationships) = @_;
7575
7576	159				156	my @unique;
7577						my %seen;
7578
7579	159				167	foreach my $rel (@$relationships) {
7580						# Create a signature for this relationship
7581	31				19	my $sig;
7582	31	100 100 100 100 100 50			58	if ($rel->{type} eq 'mutually_exclusive') {
7583	13 13				11 28	$sig = join(':', 'mutex', sort @{$rel->{params}});
7584						} elsif ($rel->{type} eq 'required_group') {
7585	5 5				4 10	$sig = join(':', 'reqgroup', sort @{$rel->{params}});
7586						} elsif ($rel->{type} eq 'conditional_requirement') {
7587	7				9	$sig = join(':', 'condreq', $rel->{if}, $rel->{then_required});
7588						} elsif ($rel->{type} eq 'dependency') {
7589	3				5	$sig = join(':', 'dep', $rel->{param}, $rel->{requires});
7590						} elsif ($rel->{type} eq 'value_constraint') {
7591	2				3	$sig = join(':', 'valcon', $rel->{if}, $rel->{then}, $rel->{operator}, $rel->{value});
7592						} elsif ($rel->{type} eq 'value_conditional') {
7593	1				3	$sig = join(':', 'valcond', $rel->{if}, $rel->{equals}, $rel->{then_required});
7594						} else {
7595	0				0	$sig = join(':', $rel->{type}, %$rel);
7596						}
7597
7598	31	100			49	unless ($seen{$sig}++) {
7599	25				21	push @unique, $rel;
7600						}
7601						}
7602
7603	159				206	return @unique;
7604						}
7605
7606						# --------------------------------------------------
7607						# _detect_mutually_exclusive
7608						#
7609						# Purpose: Detect pairs of parameters that cannot
7610						# be specified together, by searching
7611						# for die/croak/confess patterns
7612						# that fire when both are truthy.
7613						#
7614						# Entry: $code - method body source string.
7615						# $param_names - arrayref of parameter
7616						# name strings.
7617						#
7618						# Exit: Returns an arrayref of relationship
7619						# hashrefs of type 'mutually_exclusive'.
7620						# Returns an empty arrayref if none found.
7621						#
7622						# Side effects: Logs detections to stdout when
7623						# verbose is set.
7624						# --------------------------------------------------
7625						sub _detect_mutually_exclusive {
7626	160			160	1553	my ($self, $code, $param_names) = @_;
7627
7628	160				120	my @relationships;
7629
7630						# Pattern 1: die/croak if $x && $y
7631						# Look for: die/croak ... if $param1 && $param2
7632	160				185	foreach my $param1 (@$param_names) {
7633	237				223	foreach my $param2 (@$param_names) {
7634	467	100			549	next if $param1 eq $param2;
7635
7636						# Check various patterns
7637	230	100	100		10555	if ($code =~ /(?:die\|croak\|confess)[^;]*if\s+\$$param1\s+&&\s+\$$param2/ \|\|
7638						$code =~ /(?:die\|croak\|confess)[^;]*if\s+\$$param2\s+&&\s+\$$param1/) {
7639
7640						# Avoid duplicates (param1,param2 vs param2,param1)
7641	22				23	my $found_reverse = 0;
7642	22				23	foreach my $rel (@relationships) {
7643	13	100	33 67		40	if ($rel->{type} eq 'mutually_exclusive' &&
7644						(($rel->{params}[0] eq $param2 && $rel->{params}[1] eq $param1))) {
7645	11				9	$found_reverse = 1;
7646	11				11	last;
7647						}
7648						}
7649
7650	22	100			41	next if $found_reverse;
7651
7652	11				59	push @relationships, {
7653						type => 'mutually_exclusive',
7654						params => [$param1, $param2],
7655						description => "Cannot specify both $param1 and $param2"
7656						};
7657
7658	11				26	$self->_log(" RELATIONSHIP: $param1 and $param2 are mutually exclusive");
7659						}
7660
7661						# Pattern 2: die "Cannot specify both X and Y"
7662	219	100	67		21003	if ($code =~ /(?:die\|croak\|confess)\s+['"](Cannot\|Can't)[^'"]both[^'"]$param1[^'"]*$param2/i \|\|
7663						$code =~ /(?:die\|croak\|confess)\s+['"](Cannot\|Can't)[^'"]both[^'"]$param2[^'"]*$param1/i) {
7664
7665	1				2	my $found_reverse = 0;
7666	1				1	foreach my $rel (@relationships) {
7667	1	50	33 33		3	if ($rel->{type} eq 'mutually_exclusive' &&
7668						(($rel->{params}[0] eq $param2 && $rel->{params}[1] eq $param1))) {
7669	0				0	$found_reverse = 1;
7670	0				0	last;
7671						}
7672						}
7673
7674	1	50			2	next if $found_reverse;
7675
7676	1				3	push @relationships, {
7677						type => 'mutually_exclusive',
7678						params => [$param1, $param2],
7679						description => "Cannot specify both $param1 and $param2"
7680						};
7681
7682	1				11	$self->_log(" RELATIONSHIP: $param1 and $param2 are mutually exclusive (from error message)");
7683						}
7684						}
7685						}
7686
7687	160				219	return \@relationships;
7688						}
7689
7690						# --------------------------------------------------
7691						# _detect_required_groups
7692						#
7693						# Purpose: Detect parameter groups where at least
7694						# one parameter must be specified (OR
7695						# logic), by searching for die/croak
7696						# patterns that fire unless any of the
7697						# group is truthy.
7698						#
7699						# Entry: $code - method body source string.
7700						# $param_names - arrayref of parameter
7701						# name strings.
7702						#
7703						# Exit: Returns an arrayref of relationship
7704						# hashrefs of type 'required_group'.
7705						# Returns an empty arrayref if none found.
7706						#
7707						# Side effects: Logs detections to stdout when
7708						# verbose is set.
7709						# --------------------------------------------------
7710						sub _detect_required_groups {
7711	158			158	1203	my ($self, $code, $param_names) = @_;
7712
7713	158				130	my @relationships;
7714
7715						# Pattern 1: die/croak unless $x \|\| $y
7716	158				179	foreach my $param1 (@$param_names) {
7717	233				191	foreach my $param2 (@$param_names) {
7718	459	100			476	next if $param1 eq $param2;
7719
7720	226	100	100		9473	if ($code =~ /(?:die\|croak\|confess)[^;]*unless\s+\$$param1\s+\\|\\|\s+\$$param2/ \|\|
7721						$code =~ /(?:die\|croak\|confess)[^;]*unless\s+\$$param2\s+\\|\\|\s+\$$param1/) {
7722
7723						# Avoid duplicates
7724	10				10	my $found_reverse = 0;
7725	10				13	foreach my $rel (@relationships) {
7726	5	50	33 33		22	if ($rel->{type} eq 'required_group' &&
7727						(($rel->{params}[0] eq $param2 && $rel->{params}[1] eq $param1))) {
7728	5				5	$found_reverse = 1;
7729	5				5	last;
7730						}
7731						}
7732
7733	10	100			17	next if $found_reverse;
7734
7735	5				16	push @relationships, {
7736						type => 'required_group',
7737						params => [$param1, $param2],
7738						logic => 'or',
7739						description => "Must specify either $param1 or $param2"
7740						};
7741
7742	5				12	$self->_log(" RELATIONSHIP: Must specify either $param1 or $param2");
7743						}
7744
7745						# Pattern 2: die "Must specify either X or Y"
7746	221	100	67		21040	if ($code =~ /(?:die\|croak\|confess)\s+['"]Must\s+specify\s+either[^'"]$param1[^'"]or[^'"]*$param2/i \|\|
7747						$code =~ /(?:die\|croak\|confess)\s+['"]Must\s+specify\s+either[^'"]$param2[^'"]or[^'"]*$param1/i) {
7748
7749	1				1	my $found_reverse = 0;
7750	1				1	foreach my $rel (@relationships) {
7751	1	50	33 33		3	if ($rel->{type} eq 'required_group' &&
7752						(($rel->{params}[0] eq $param2 && $rel->{params}[1] eq $param1))) {
7753	0				0	$found_reverse = 1;
7754	0				0	last;
7755						}
7756						}
7757
7758	1	50			2	next if $found_reverse;
7759
7760	1				2	push @relationships, {
7761						type => 'required_group',
7762						params => [$param1, $param2],
7763						logic => 'or',
7764						description => "Must specify either $param1 or $param2"
7765						};
7766
7767	1				2	$self->_log(" RELATIONSHIP: Must specify either $param1 or $param2 (from error message)");
7768						}
7769						}
7770						}
7771
7772	158				181	return \@relationships;
7773						}
7774
7775						# --------------------------------------------------
7776						# _detect_conditional_requirements
7777						#
7778						# Purpose: Detect IF-THEN parameter relationships
7779						# where one parameter being present
7780						# makes another required, by searching
7781						# for die/croak patterns of the form
7782						# 'die if $x && !$y'.
7783						#
7784						# Entry: $code - method body source string.
7785						# $param_names - arrayref of parameter
7786						# name strings.
7787						#
7788						# Exit: Returns an arrayref of relationship
7789						# hashrefs of type
7790						# 'conditional_requirement'.
7791						# Returns an empty arrayref if none found.
7792						#
7793						# Side effects: Logs detections to stdout when
7794						# verbose is set.
7795						# --------------------------------------------------
7796						sub _detect_conditional_requirements {
7797	158			158	1482	my ($self, $code, $param_names) = @_;
7798
7799	158				146	my @relationships;
7800
7801	158				163	foreach my $param1 (@$param_names) {
7802	233				233	foreach my $param2 (@$param_names) {
7803	459	100			430	next if $param1 eq $param2;
7804
7805						# Pattern 1: die if $x && !$y (if x then y required)
7806	226	100			4818	if ($code =~ /(?:die\|croak\|confess)[^;]*if\s+\$$param1\s+&&\s+!\$$param2/) {
7807	5				19	push @relationships, {
7808						type => 'conditional_requirement',
7809						if => $param1,
7810						then_required => $param2,
7811						description => "When $param1 is specified, $param2 is required"
7812						};
7813
7814	5				10	$self->_log(" RELATIONSHIP: $param1 requires $param2");
7815						}
7816
7817						# Pattern 2: die if $x && !defined($y)
7818	226	50			6834	if ($code =~ /(?:die\|croak\|confess)[^;]if\s+\$$param1\s+&&\s+!defined\s$\s\$$param2\s$/) {
7819	0				0	push @relationships, {
7820						type => 'conditional_requirement',
7821						if => $param1,
7822						then_required => $param2,
7823						description => "When $param1 is specified, $param2 is required"
7824						};
7825
7826	0				0	$self->_log(" RELATIONSHIP: $param1 requires $param2 (defined check)");
7827						}
7828
7829						# Pattern 3: Error message "X requires Y"
7830	226	100			10663	if ($code =~ /(?:die\|croak\|confess)\s+['"]\w$param1[^'"]requires[^'"]*$param2/i) {
7831	4				11	push @relationships, {
7832						type => 'conditional_requirement',
7833						if => $param1,
7834						then_required => $param2,
7835						description => "When $param1 is specified, $param2 is required"
7836						};
7837
7838	4				7	$self->_log(" RELATIONSHIP: $param1 requires $param2 (from error message)");
7839						}
7840						}
7841						}
7842
7843	158				187	return \@relationships;
7844						}
7845
7846						# --------------------------------------------------
7847						# _detect_dependencies
7848						#
7849						# Purpose: Detect simple parameter dependencies
7850						# where one parameter requires another
7851						# to also be present, by combining
7852						# error message pattern matching with
7853						# code condition matching.
7854						#
7855						# Entry: $code - method body source string.
7856						# $param_names - arrayref of parameter
7857						# name strings.
7858						#
7859						# Exit: Returns an arrayref of relationship
7860						# hashrefs of type 'dependency'.
7861						# Returns an empty arrayref if none found.
7862						#
7863						# Side effects: Logs detections to stdout when
7864						# verbose is set.
7865						# --------------------------------------------------
7866						sub _detect_dependencies {
7867	159			159	27452	my ($self, $code, $param_names) = @_;
7868
7869	159				112	my @relationships;
7870
7871	159				168	foreach my $param1 (@$param_names) {
7872	235				204	foreach my $param2 (@$param_names) {
7873	463	100			412	next if $param1 eq $param2;
7874
7875						# Pattern 1: Error message mentions "X requires Y" AND code checks $x && !$y
7876						# Split into two checks to be more flexible
7877	228	100	100		9891	if (($code =~ /(?:die\|croak\|confess)\s+['"]\w$param1[^'"]requires[^'"]*$param2/i) &&
7878						($code =~ /if\s+\$$param1\s+&&\s+!\$$param2/)) {
7879
7880	6				26	push @relationships, {
7881						type => 'dependency',
7882						param => $param1,
7883						requires => $param2,
7884						description => "$param1 requires $param2 to be specified"
7885						};
7886
7887	6				17	$self->_log(" RELATIONSHIP: $param1 depends on $param2");
7888						}
7889						}
7890						}
7891
7892	159				171	return \@relationships;
7893						}
7894
7895						# --------------------------------------------------
7896						# _detect_value_constraints
7897						#
7898						# Purpose: Detect value-based constraints between
7899						# parameters, such as 'if $ssl then
7900						# $port must equal 443' or 'if $mode
7901						# eq secure then $key is required'.
7902						#
7903						# Entry: $code - method body source string.
7904						# $param_names - arrayref of parameter
7905						# name strings.
7906						#
7907						# Exit: Returns an arrayref of relationship
7908						# hashrefs of type 'value_constraint'
7909						# or 'value_conditional'.
7910						# Returns an empty arrayref if none found.
7911						#
7912						# Side effects: Logs detections to stdout when
7913						# verbose is set.
7914						# --------------------------------------------------
7915						sub _detect_value_constraints {
7916	156			156	229	my ($self, $code, $param_names) = @_;
7917
7918	156				119	my @relationships;
7919
7920	156				145	foreach my $param1 (@$param_names) {
7921	229				207	foreach my $param2 (@$param_names) {
7922	451	100			436	next if $param1 eq $param2;
7923
7924						# Pattern 1: die if $x && $y != value
7925	222	100			6494	if ($code =~ /(?:die\|croak\|confess)[^;]if\s+\$$param1\s+&&\s+\$$param2\s!=\s*(\d+)/) {
7926	3				6	my $value = $1;
7927	3				12	push @relationships, {
7928						type => 'value_constraint',
7929						if => $param1,
7930						then => $param2,
7931						operator => '==',
7932						value => $value,
7933						description => "When $param1 is specified, $param2 must equal $value"
7934						};
7935
7936	3				8	$self->_log(" RELATIONSHIP: $param1 requires $param2 == $value");
7937						}
7938
7939						# Pattern 2: die if $x && $y < value
7940	222	50			6337	if ($code =~ /(?:die\|croak\|confess)[^;]if\s+\$$param1\s+&&\s+\$$param2\s<\s*(\d+)/) {
7941	0				0	my $value = $1;
7942	0				0	push @relationships, {
7943						type => 'value_constraint',
7944						if => $param1,
7945						then => $param2,
7946						operator => '>=',
7947						value => $value,
7948						description => "When $param1 is specified, $param2 must be >= $value"
7949						};
7950
7951	0				0	$self->_log(" RELATIONSHIP: $param1 requires $param2 >= $value");
7952						}
7953
7954						# Pattern 3: die if $x eq 'value' && !$y
7955	222	100			8156	if ($code =~ /(?:die\|croak\|confess)[^;]*if\s+\$$param1\s+eq\s+['"]([^'"]+)['"]\s+&&\s+!\$$param2/) {
7956	1				3	my $value = $1;
7957	1				3	push @relationships, {
7958						type => 'value_conditional',
7959						if => $param1,
7960						equals => $value,
7961						then_required => $param2,
7962						description => "When $param1 equals '$value', $param2 is required"
7963						};
7964
7965	1				2	$self->_log(" RELATIONSHIP: $param1='$value' requires $param2");
7966						}
7967						}
7968						}
7969
7970	156				163	return \@relationships;
7971						}
7972
7973						# Write a single method schema to a YAML file in output_dir.
7974						#
7975						# Entry: $method_name is a non-empty string; $schema is a hashref.
7976						# Exit: YAML file written to output_dir/$method_name.yml.
7977						# Side effects: Creates output_dir if it does not exist.
7978						# Notes: Croaks if output_dir was not set in new().
7979
7980						sub _write_schema {
7981	123			123	3382	my ($self, $method_name, $schema) = @_;
7982
7983						# output_dir is required here â€” croak early with a clear message
7984						# rather than letting make_path fail with a cryptic error
7985	123	100			214	croak(__PACKAGE__, ': output_dir must be provided to new() when writing schema files') unless defined $self->{output_dir};
7986
7987	122	100			2092	make_path($self->{output_dir}) unless -d $self->{output_dir};
7988
7989	122				172	my $filename = "$self->{output_dir}/${method_name}.yml";
7990
7991						# Configure YAML::XS to not quote numeric strings
7992	122				148	local $YAML::XS::QuoteNumericStrings = 0;
7993
7994						# Extract package name for module field
7995	122				123	my $package_name = '';
7996	122	100			271	if ($self->{_document}) {
7997	121				229	my $package_stmt = $self->{_document}->find_first('PPI::Statement::Package');
7998	121	100			19700	$package_name = $package_stmt ? $package_stmt->namespace : '';
7999	121		33		1573	$self->{_package_name} //= $package_name;
8000						}
8001
8002						# Clean up schema for output - use the format expected by App::Test::Generator::Template
8003	122				561	my $output = {
8004						function => $method_name,
8005						module => $package_name,
8006						config => {
8007						close_stdin => 1,
8008						dedup => 1,
8009						test_nuls => 0,
8010						test_undef => 0,
8011						test_empty => 1,
8012						test_non_ascii => 0,
8013						test_security => 0
8014						}
8015						};
8016
8017						# Process input parameters with advanced type handling
8018	122	100			191	if($schema->{'input'}) {
8019	119 119	100			93 182	if(scalar(keys %{$schema->{'input'}})) {
8020	97				128	$output->{'input'} = {};
8021
8022	97 97				84 202	foreach my $param_name (keys %{$schema->{'input'}}) {
8023	162				150	my $param = $schema->{'input'}{$param_name};
8024	162	100			186	if($param->{name}) {
8025	24				21	my $name = delete $param->{name};
8026	24	50			26	if($name ne $param_name) {
8027						# Sanity check
8028	0				0	croak("BUG: Parameter name - expected $param_name, got $name");
8029						}
8030						}
8031	162				242	my $cleaned_param = $self->_serialize_parameter_for_yaml($param);
8032	162				193	$output->{'input'}{$param_name} = $cleaned_param;
8033						}
8034
8035						# If some params have positions and others don't, treat the whole
8036						# input as a named (hash) API and strip all positions. Mixed
8037						# position state arises when a named-API method also happens to
8038						# have a Params::Get positional-key call alongside =head4 Input
8039						# named-block params that carry no position.
8040	97 162 97				106 247 154	my @with_pos = grep { defined $output->{input}{$_}{position} } keys %{$output->{input}};
8041	97 162 97				92 201 104	my @without_pos = grep { !defined $output->{input}{$_}{position} } keys %{$output->{input}};
8042	97	50	67		240	if (@with_pos && @without_pos) {
8043	0				0	delete $output->{input}{$_}{position} for @with_pos;
8044						}
8045						} else {
8046	22				26	delete $output->{input};
8047						}
8048						}
8049
8050						# Process output
8051	122 122	50	50		212 202	if($schema->{'output'} && (scalar(keys %{$schema->{'output'}}))) {
8052	122 121	100	100		234 210	if((ref($schema->{output}{_error_handling}) eq 'HASH') && (scalar(keys %{$schema->{output}{_error_handling}}) == 0)) {
8053	108				120	delete $schema->{output}{_error_handling};
8054						}
8055	122				173	$output->{'output'} = $schema->{'output'};
8056						}
8057
8058	122	50	67		332	if($schema->{'output'}{'type'} && ($schema->{'output'}{'type'} eq 'scalar')) {
8059	0				0	$schema->{'output'}{'type'} = 'string';
8060	0				0	$schema->{_confidence}{output}->{level} = 'low'; # A guess
8061						}
8062
8063						# Add 'new' field if object instantiation is needed
8064	122	100			154	if ($schema->{new}) {
8065						# TODO: consider allowing parent class packages up the ISA chain
8066	87	100	67		197	if(ref($schema->{new}) \|\| ($schema->{new} eq $package_name)) {
8067	86	50			157	$output->{new} = $schema->{new} eq $package_name ? undef : $schema->{'new'};
8068						} else {
8069	1				3	$self->_log(" NEW: Don't use $schema->{new} for object insantiation");
8070	1				1	delete $schema->{new};
8071	1				1	delete $output->{new};
8072						}
8073						}
8074
8075	122	100			198	if(!defined($schema->{_confidence}{input}->{level})) {
8076	89				187	$schema->{_confidence}{input} = $self->_calculate_input_confidence($schema->{input});
8077						}
8078	122	100			189	if(!defined($schema->{_confidence}{output}->{level})) {
8079	1				4	$schema->{_confidence}{output} = $self->_calculate_output_confidence($schema->{output});
8080						}
8081
8082						# Add relationships if detected
8083	122 7	100	67		205 8	if ($schema->{relationships} && @{$schema->{relationships}}) {
8084	7				6	$output->{relationships} = $schema->{relationships};
8085						}
8086
8087	122 7	50	100		164 12	if($schema->{accessor} && scalar(keys %{$schema->{accessor}})) {
8088	7				9	$output->{accessor} = $schema->{accessor};
8089						}
8090
8091	122				299	open my $fh, '>', $filename;
8092	122				37511	print $fh YAML::XS::Dump($output);
8093	122				637	print $fh $self->_generate_schema_comments($schema, $method_name);
8094	122				247	close $fh;
8095
8096						my $rel_info = $schema->{relationships} ?
8097	122 7	100			14817 10	' [' . scalar(@{$schema->{relationships}}) . ' relationships]' : '';
8098						$self->_log(" Wrote: $filename (input confidence: $schema->{_confidence}{input}->{level})" .
8099	122	100			423	($schema->{new} ? " [requires: $schema->{new}]" : '') . $rel_info);
8100						}
8101
8102						# --------------------------------------------------
8103						# _generate_schema_comments
8104						#
8105						# Purpose: Generate the YAML comment block
8106						# appended to the end of each written
8107						# schema file, containing provenance,
8108						# confidence levels, parameter type
8109						# notes, relationship summaries, and
8110						# warnings about types requiring
8111						# special test setup.
8112						#
8113						# Entry: $schema - the schema hashref as
8114						# built by _analyze_method.
8115						# $method_name - the method name string,
8116						# used in the fuzz
8117						# command hint.
8118						#
8119						# Exit: Returns a string of YAML comment lines
8120						# beginning with a blank line and ending
8121						# with a trailing newline.
8122						#
8123						# Side effects: None.
8124						# --------------------------------------------------
8125						sub _generate_schema_comments {
8126	127			127	226	my ($self, $schema, $method_name) = @_;
8127
8128	127				107	my @comments;
8129
8130	127				160	push @comments, '';
8131	127				231	push @comments, '# Generated by ' . ref($self);
8132	127				259	push @comments, "# Run: fuzz-harness-generator -r $self->{output_dir}/${method_name}.yml";
8133	127				126	push @comments, '#';
8134	127				195	push @comments, "# Input confidence: $schema->{_confidence}{input}->{level}";
8135	127				198	push @comments, "# Output confidence: $schema->{_confidence}{output}->{level}";
8136
8137						# Add notes about parameters
8138	127	100			215	if ($schema->{input}) {
8139	119				96	my @param_notes;
8140	119 119				127 259	foreach my $param_name (sort keys %{$schema->{input}}) {
8141	162				148	my $p = $schema->{input}{$param_name};
8142
8143	162	100			213	if ($p->{semantic}) {
8144	18				31	push @param_notes, "$param_name: $p->{semantic}";
8145						}
8146
8147	162	100			205	if ($p->{enum}) {
8148	5 5				7 8	push @param_notes, "$param_name: enum with " . scalar(@{$p->{enum}}) . " values";
8149						}
8150
8151	162	100			203	if ($p->{isa}) {
8152	6				9	push @param_notes, "$param_name: requires $p->{isa} object";
8153						}
8154						}
8155
8156	119	100			168	if (@param_notes) {
8157	20				22	push @comments, '#';
8158	20				21	push @comments, '# Parameter types detected:';
8159	20				21	foreach my $note (@param_notes) {
8160	29				39	push @comments, "# - $note";
8161						}
8162						}
8163						}
8164
8165						# Add relationship notes
8166	127 8	100	67		239 16	if ($schema->{relationships} && @{$schema->{relationships}}) {
8167	8				12	push @comments, (
8168						'#',
8169						'# Parameter relationships detected:'
8170						);
8171	8 8				7 10	foreach my $rel (@{$schema->{relationships}}) {
8172	17		33		18	my $desc = $rel->{description} \|\| _format_relationship($rel);
8173	17				20	push @comments, "# - $desc";
8174						}
8175						}
8176
8177						# Add general notes
8178	127 126	100	100		218 248	if ($schema->{_notes} && scalar(@{$schema->{_notes}})) {
8179	32				32	push @comments, '#';
8180	32				27	push @comments, '# Notes:';
8181	32 32				23 43	foreach my $note (@{$schema->{_notes}}) {
8182	50				57	push @comments, "# - $note";
8183						}
8184						}
8185
8186	127	100			181	if($schema->{_analysis}) {
8187	121				160	push @comments, (
8188						'#',
8189						'# Analysis:',
8190						'# TODO:',
8191						);
8192						# confidence_factors:
8193						# input:
8194						# - No parameters found
8195						# output:
8196						# - 'Return type defined: object (+30)'
8197						# - 'Total output confidence score: 30'
8198						# - 'Medium confidence: return type defined'
8199						# input_confidence: none
8200						# output_confidence: medium
8201						# overall_confidence: none
8202						}
8203
8204						# Add warnings for complex types
8205	127				97	my @warnings;
8206	127	100			158	if ($schema->{input}) {
8207	119 119				103 162	foreach my $param_name (keys %{$schema->{input}}) {
8208	162				150	my $p = $schema->{input}{$param_name};
8209
8210	162	100	67		285	if ($p->{type} && $p->{type} eq 'coderef') {
8211	3				5	push @warnings, "Parameter '$param_name' is a coderef - you'll need to provide a sub {} in tests";
8212						}
8213
8214	162	100	100		204	if ($p->{semantic} && $p->{semantic} eq 'filehandle') {
8215	2				3	push @warnings, "Parameter '$param_name' is a filehandle - consider using IO::String or mock";
8216						}
8217
8218	162	100	100		239	if ($p->{isa} && $p->{isa} =~ /DateTime/) {
8219	2				3	push @warnings, "Parameter '$param_name' requires DateTime - ensure DateTime is loaded";
8220						}
8221						}
8222						}
8223
8224	127	100			219	if (@warnings) {
8225	7				7	push @comments, '#';
8226	7				6	push @comments, '# WARNINGS - Manual test setup may be required:';
8227	7				8	foreach my $warning (@warnings) {
8228	7				8	push @comments, "# ! $warning";
8229						}
8230						}
8231
8232	127				142	push @comments, '';
8233
8234	127				347	return join("\n", @comments);
8235						}
8236
8237						# --------------------------------------------------
8238						# _serialize_parameter_for_yaml
8239						#
8240						# Purpose: Convert a parameter spec hashref into
8241						# a cleaned, YAML-serialisable form
8242						# suitable for App::Test::Generator
8243						# consumption, handling semantic type
8244						# mappings, enum values, and object
8245						# class annotations.
8246						#
8247						# Entry: $param - parameter spec hashref as
8248						# produced by the merge and
8249						# analysis pipeline.
8250						#
8251						# Exit: Returns a new hashref containing only
8252						# the fields App::Test::Generator
8253						# understands, with internal _ keys
8254						# and semantic keys removed or converted.
8255						#
8256						# Side effects: None.
8257						#
8258						# Notes: Semantic types are mapped to
8259						# appropriate base types with additional
8260						# constraint and note fields.
8261						# The original $param hashref is not
8262						# modified.
8263						# --------------------------------------------------
8264						sub _serialize_parameter_for_yaml {
8265	177			177	3198	my ($self, $param) = @_;
8266
8267	177				125	my %cleaned;
8268
8269						# Copy basic fields that App::Test::Generator expects
8270	177				206	foreach my $field (qw(type position optional min max matches default)) {
8271	1239	100			1238	$cleaned{$field} = $param->{$field} if defined $param->{$field};
8272						}
8273
8274						# Handle advanced type mappings
8275	177	100			215	if(my $semantic = $param->{semantic}) {
8276	25	100 50 100 100 100 50 100 100 100 100			147	if ($semantic eq 'datetime_object') {
8277						# DateTime objects: test generator needs to know how to create them
8278	2				2	$cleaned{type} = 'object';
8279	2		50		5	$cleaned{isa} = $param->{isa} \|\| 'DateTime';
8280	2				3	$cleaned{_note} = 'Requires DateTime object';
8281						} elsif ($semantic eq 'timepiece_object') {
8282	0				0	$cleaned{type} = 'object';
8283	0		0		0	$cleaned{isa} = $param->{isa} \|\| 'Time::Piece';
8284	0				0	$cleaned{_note} = 'Requires Time::Piece object';
8285						} elsif ($semantic eq 'date_string') {
8286						# Date strings: provide regex pattern
8287	1				2	$cleaned{type} = 'string';
8288	1		50		4	$cleaned{matches} \|\|= '/^\d{4}-\d{2}-\d{2}$/';
8289	1				2	$cleaned{_example} = '2024-12-12';
8290						} elsif ($semantic eq 'iso8601_string') {
8291	1				1	$cleaned{type} = 'string';
8292	1		50		2	$cleaned{matches} \|\|= '/^\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}Z?$/';
8293	1				2	$cleaned{_example} = '2024-12-12T10:30:00Z';
8294						} elsif ($semantic eq 'unix_timestamp') {
8295	3				7	$cleaned{type} = 'integer';
8296	3		50		10	$cleaned{min} \|\|= 0;
8297	3		67		8	$cleaned{max} \|\|= $INT32_MAX; # 32-bit max
8298	3				8	$cleaned{_note} = 'UNIX timestamp';
8299						} elsif ($semantic eq 'datetime_parseable') {
8300	0				0	$cleaned{type} = 'string';
8301	0				0	$cleaned{_note} = 'Must be parseable as datetime';
8302						} elsif ($semantic eq 'filehandle') {
8303						# File handles: special handling needed
8304	2				3	$cleaned{type} = 'object';
8305	2		50		4	$cleaned{isa} = $param->{isa} \|\| 'IO::Handle';
8306	2				21	$cleaned{_note} = 'File handle - may need mock in tests';
8307						} elsif ($semantic eq 'filepath') {
8308						# File paths: string with path pattern
8309	3				6	$cleaned{type} = 'string';
8310	3		50		10	$cleaned{matches} \|\|= '/^[\\w\\/.\\-_]+$/';
8311	3				3	$cleaned{_note} = 'File path';
8312						} elsif ($semantic eq 'callback') {
8313						# Coderefs: mark as special type
8314	5				5	$cleaned{type} = 'coderef';
8315	5				8	$cleaned{_note} = 'CODE reference - provide sub { } in tests';
8316						} elsif ($semantic eq 'enum') {
8317						# Enum: keep as string but add valid values
8318	5				9	$cleaned{type} = 'string';
8319	5	50	33		17	if ($param->{enum} && ref($param->{enum}) eq 'ARRAY') {
8320	5				7	$cleaned{enum} = $param->{enum};
8321	5 5				5 13	$cleaned{_note} = 'Must be one of: ' . join(', ', @{$param->{enum}});
8322						}
8323						}
8324						}
8325
8326						# Handle memberof even if not marked with semantic.
8327						# enum and memberof are mutually exclusive â€” only set memberof when enum
8328						# is not already being output (avoids the "has both" validation error).
8329	177	100	75		250	if($param->{enum} && ref($param->{enum}) eq 'ARRAY' && !$cleaned{enum}) {
8330	2				3	$cleaned{memberof} = $param->{enum};
8331						}
8332	177	50	33		229	if($param->{memberof} && ref($param->{memberof}) eq 'ARRAY') {
8333	0				0	$cleaned{memberof} = $param->{memberof};
8334						}
8335
8336						# Handle object class
8337	177	100	100		239	if ($param->{isa} && !$cleaned{isa}) {
8338	4				5	$cleaned{isa} = $param->{isa};
8339						}
8340
8341						# Add format hints where available
8342	177	100			184	if ($param->{format}) {
8343	1				2	$cleaned{_format} = $param->{format};
8344						}
8345
8346						# Remove internal fields
8347	177				155	delete $cleaned{_source};
8348	177				127	delete $cleaned{_from_input_spec};
8349	177				162	delete $cleaned{semantic};
8350
8351	177				173	return \%cleaned;
8352						}
8353
8354						# --------------------------------------------------
8355						# _format_relationship
8356						#
8357						# Purpose: Format a relationship hashref as a
8358						# short human-readable description
8359						# string for use in YAML comments.
8360						#
8361						# Entry: $rel - relationship hashref as
8362						# produced by the relationship
8363						# detection methods.
8364						#
8365						# Exit: Returns a description string.
8366						# Returns 'Unknown relationship' for
8367						# unrecognised types.
8368						#
8369						# Side effects: None.
8370						# --------------------------------------------------
8371						sub _format_relationship {
8372	14			14	6890	my $rel = $_[0];
8373
8374	14	100 100 100 100 100 100			37	if ($rel->{type} eq 'mutually_exclusive') {
8375	3 3				3 28	return 'Mutually exclusive: ' . join(', ', @{$rel->{params}});
8376						} elsif ($rel->{type} eq 'required_group') {
8377	2 2				3 6	return "Required group (OR): " . join(', ', @{$rel->{params}});
8378						} elsif ($rel->{type} eq 'conditional_requirement') {
8379	2				5	return "If $rel->{if} then $rel->{then_required} required";
8380						} elsif ($rel->{type} eq 'dependency') {
8381	3				8	return "$rel->{param} depends on $rel->{requires}";
8382						} elsif ($rel->{type} eq 'value_constraint') {
8383	2				7	return "If $rel->{if} then $rel->{then} $rel->{operator} $rel->{value}";
8384						} elsif ($rel->{type} eq 'value_conditional') {
8385	1				3	return "If $rel->{if}='$rel->{equals}' then $rel->{then_required} required";
8386						}
8387	1				3	return 'Unknown relationship';
8388						}
8389
8390						# --------------------------------------------------
8391						# _needs_object_instantiation
8392						#
8393						# Purpose: Determine whether a method requires
8394						# an object to be instantiated before
8395						# it can be called, and if so return
8396						# the package name to instantiate.
8397						#
8398						# Entry: $method_name - name of the method.
8399						# $method_body - method source string.
8400						# $method_info - method hashref from
8401						# _find_methods (optional,
8402						# for backward compat).
8403						#
8404						# Exit: Returns the package name string if
8405						# object instantiation is required.
8406						# Returns undef if the method is a
8407						# constructor, factory, singleton, or
8408						# pure class method.
8409						#
8410						# Side effects: Logs analysis decisions to stdout
8411						# when verbose is set.
8412						#
8413						# Notes: Orchestrates five detection sub-steps:
8414						# factory detection, singleton detection,
8415						# instance method detection, inheritance
8416						# check, and constructor requirements.
8417						# Instance method detection overrides
8418						# factory detection when both fire.
8419						# --------------------------------------------------
8420						sub _needs_object_instantiation {
8421	336			336	1558	my ($self, $method_name, $method_body, $method_info) = @_;
8422
8423						# Allow method_info to be optional for backward compatibility
8424	336		50		357	$method_info \|\|= {};
8425
8426	336				361	my $doc = $self->{_document};
8427	336	50			723	return undef unless $doc;
8428
8429						# Get the current package name
8430	336				571	my $package_stmt = $doc->find_first('PPI::Statement::Package');
8431	336	100			38345	my $current_package = $package_stmt ? $package_stmt->namespace : 'UNKNOWN';
8432	336		67		4435	$self->{_package_name} //= $current_package;
8433
8434						# Initialize result structure
8435	336				856	my $result = {
8436						package => $current_package,
8437						needs_object => 0,
8438						type => 'unknown',
8439						details => {},
8440						constructor_params => undef,
8441						};
8442
8443						# Track whether we should explicitly skip object instantiation
8444	336				304	my $skip_object = 0;
8445
8446						# Skip constructors and destructors
8447	336	100			382	if ($method_name eq 'new') {
8448	22				41	$self->_log(" OBJECT: Constructor '$method_name' detected; skipping instantiation analysis");
8449	22				46	return undef;
8450						}
8451	314	100			609	if($method_name =~ /^(create\|build\|construct\|init\|DESTROY)$/i) {
8452	1				2	$skip_object = 1;
8453						}
8454
8455						# 1. Check for factory methods that return instances
8456	314				542	my $is_factory = $self->_detect_factory_method(
8457						$method_name, $method_body, $current_package, $method_info
8458						);
8459
8460						# 2. Check for singleton patterns
8461	314				460	my $is_singleton = $self->_detect_singleton_pattern($method_name, $method_body);
8462	314	100			352	if ($is_singleton) {
8463	1				2	$result->{needs_object} = 0; # Singleton methods return the singleton instance
8464	1				1	$result->{type} = 'singleton_accessor';
8465	1				1	$result->{details} = $is_singleton;
8466	1				3	$self->_log(" OBJECT: Detected singleton accessor '$method_name'");
8467						# Singleton accessors typically don't need object creation in tests
8468						# as they're called on the class, not instance
8469	1				1	$skip_object = 1;
8470						}
8471
8472						# 3. Check if this is an instance method that needs an object
8473	314				426	my $is_instance_method = $self->_detect_instance_method($method_name, $method_body);
8474	314	0	50		514	if ($is_instance_method &&
8475						($is_instance_method->{explicit_self} \|\|
8476						$is_instance_method->{shift_self} \|\|
8477						$is_instance_method->{accesses_object_data} \|\|
8478						($is_instance_method->{calls_instance_methods} &&
8479						scalar @{$is_instance_method->{calls_instance_methods}}))) {
8480
8481						# Instance-only methods override factory detection
8482	160	100			199	if ($is_factory) {
8483	3				5	$self->_log(
8484						" OBJECT: Instance-only method '$method_name' overrides factory detection"
8485						);
8486						}
8487
8488	160				159	$result->{needs_object} = 1;
8489	160				152	$result->{type} = 'instance_method';
8490	160				152	$result->{details} = $is_instance_method;
8491
8492						# 4. Check for inheritance - if parent class constructor should be used
8493	160				244	my $inheritance_info = $self->_check_inheritance_for_constructor(
8494						$current_package, $method_body
8495						);
8496	160	50	67		247	if ($inheritance_info && $inheritance_info->{use_parent_constructor}) {
8497	0				0	$result->{package} = $inheritance_info->{parent_class};
8498	0				0	$result->{details}{inheritance} = $inheritance_info;
8499	0				0	$self->_log(
8500						" OBJECT: Method '$method_name' uses parent class constructor: $inheritance_info->{parent_class}"
8501						);
8502						}
8503
8504						# 5. Check if constructor needs specific parameters
8505						my $constructor_needs = $self->_detect_constructor_requirements(
8506						$current_package, $result->{package}
8507	160				301	);
8508	160	100			184	if ($constructor_needs) {
8509	3				4	$result->{constructor_params} = $constructor_needs;
8510	3				4	$result->{details}{constructor_requirements} = $constructor_needs;
8511	3				10	$self->_log(
8512						" OBJECT: Constructor for $result->{package} requires parameters"
8513						);
8514						}
8515
8516						# Return the package name (or parent package) that needs instantiation
8517	160				495	return $result->{package};
8518						}
8519
8520						# 6. Check for class methods that might need objects from other classes
8521	154				222	my $needs_other_object = $self->_detect_external_object_dependency($method_body);
8522	154	50			136	if ($needs_other_object) {
8523	0				0	$result->{needs_object} = 1;
8524	0				0	$result->{type} = 'external_dependency';
8525						$result->{package} = $needs_other_object->{package}
8526	0	0			0	if $needs_other_object->{package};
8527	0				0	$result->{details} = $needs_other_object;
8528
8529	0				0	$self->_log(
8530						" OBJECT: Method '$method_name' depends on external object: $needs_other_object->{package}"
8531						);
8532	0	0			0	return $result->{package} if $result->{package};
8533						}
8534
8535						# Factory method only if NOT instance-based
8536	154	100	100		163	if ($is_factory && !$skip_object) {
8537	1				2	$result->{needs_object} = 0;
8538	1				1	$result->{type} = 'factory';
8539	1				1	$result->{details} = $is_factory;
8540						$self->_log(
8541						" OBJECT: Detected factory method '$method_name' returns $is_factory->{returns_class} objects"
8542	1	50			3	) if $is_factory->{returns_class};
8543						}
8544
8545	154				266	return undef;
8546						}
8547
8548						# --------------------------------------------------
8549						# _detect_factory_method
8550						#
8551						# Purpose: Detect whether a method is a factory
8552						# that creates and returns object
8553						# instances rather than operating on
8554						# an existing instance.
8555						#
8556						# Entry: $method_name - method name string.
8557						# $method_body - method source string.
8558						# $current_package - current package name.
8559						# $method_info - method hashref
8560						# (optional).
8561						#
8562						# Exit: Returns a factory_info hashref on
8563						# detection, or undef if the method
8564						# is not a factory.
8565						# The hashref includes: returns_class,
8566						# confidence, and one of:
8567						# returns_blessed, returns_new,
8568						# returns_factory_result, pod_hint.
8569						#
8570						# Side effects: None.
8571						# --------------------------------------------------
8572						sub _detect_factory_method {
8573	320			320	12343	my ($self, $method_name, $method_body, $current_package, $method_info) = @_;
8574
8575	320				251	my %factory_info;
8576
8577						# Check method name patterns
8578	320	100			487	if ($method_name =~ /^(create_\|make_\|build_\|get_)/i) {
8579	11				20	$factory_info{name_pattern} = 1;
8580						}
8581
8582						# Look for object creation patterns in the method body
8583	320	50			340	if ($method_body) {
8584						# Pattern 1: Returns a blessed reference
8585	320	100	67		973	if ($method_body =~ /return\s+bless\s\{[^}]\},\s['"]?(\w+(?:::\w+)\|\$\w+)['"]?/s \|\|
8586						$method_body =~ /bless\s\{[^}]\},\s['"]?(\w+(?:::\w+)\|\$\w+)['"]?.*return/s) {
8587	6				9	my $class_name = $1;
8588
8589						# Handle variable class names
8590	6	100 100			19	if ($class_name =~ /^\$(class\|self\|package)$/) {
8591	2				2	$factory_info{returns_class} = $current_package;
8592						} elsif ($class_name =~ /^\$/) {
8593	1				2	$factory_info{returns_class} = 'VARIABLE'; # Unknown variable
8594						} else {
8595	3				4	$factory_info{returns_class} = $class_name;
8596						}
8597
8598	6				12	$factory_info{returns_blessed} = 1;
8599	6				6	$factory_info{confidence} = 'high';
8600	6				10	return \%factory_info;
8601						}
8602
8603						# Pattern 2: Returns ->new() call on class or $self
8604	314	100	100		823	if ($method_body =~ /return\s+([\$\w:]+)->new\(/s \|\|
8605						$method_body =~ /([\$\w:]+)->new\(.*return/s) {
8606	5				9	my $target = $1;
8607
8608						# Determine what class is being instantiated
8609	5	50 100	25		22	if ($target eq '$self' \|\| $target eq 'shift' \|\| $target =~ /^\$/) {
8610	0				0	$factory_info{returns_class} = $current_package;
8611	0				0	$factory_info{self_new} = 1;
8612						} elsif ($target =~ /::/) {
8613	1				2	$factory_info{returns_class} = $target;
8614	1				2	$factory_info{external_class} = 1;
8615						} else {
8616	4				6	$factory_info{returns_class} = $target;
8617						}
8618
8619	5				7	$factory_info{returns_new} = 1;
8620	5				7	$factory_info{confidence} = 'medium';
8621	5				10	return \%factory_info;
8622						}
8623
8624						# Pattern 3: Returns an object from another factory method
8625	309	50	33		1175	if ($method_body =~ /return\s+([\$\w:]+)->(create_\|make_\|build_\|get_)/i \|\|
8626						$method_body =~ /([\$\w:]+)->(create_\|make_\|build_\|get_).*return/si) {
8627	0				0	$factory_info{returns_factory_result} = 1;
8628	0				0	$factory_info{confidence} = 'low';
8629	0				0	return \%factory_info;
8630						}
8631						}
8632
8633						# Check for return type hints in POD if available
8634	309	100	50		854	if ($method_info && ref($method_info) eq 'HASH' && $method_info->{pod}) {
8635	115				122	my $pod = $method_info->{pod};
8636	115	50			302	if ($pod =~ /returns?\s+(?:an?\s+)?(object\|instance\|new\s+\w+)/i) {
8637	0				0	$factory_info{pod_hint} = 1;
8638	0				0	$factory_info{confidence} = 'low';
8639	0				0	return \%factory_info;
8640						}
8641						}
8642
8643	309				367	return undef;
8644						}
8645
8646						# --------------------------------------------------
8647						# _detect_singleton_pattern
8648						#
8649						# Purpose: Detect singleton accessor methods
8650						# that return a shared instance rather
8651						# than creating a new object, by
8652						# checking the method name and body
8653						# for singleton patterns.
8654						#
8655						# Entry: $method_name - method name string.
8656						# $method_body - method source string.
8657						#
8658						# Exit: Returns a singleton_info hashref on
8659						# detection (always contains at least
8660						# name_pattern => 1), or undef if the
8661						# method name does not match the
8662						# singleton accessor pattern.
8663						#
8664						# Side effects: None.
8665						#
8666						# Notes: Only fires for methods named
8667						# instance, get_instance, singleton,
8668						# or shared_instance. Methods not
8669						# matching these names always return
8670						# undef regardless of body content.
8671						# --------------------------------------------------
8672						sub _detect_singleton_pattern {
8673	323			323	1166	my ($self, $method_name, $method_body) = @_;
8674
8675						# Check method name patterns
8676	323	100			567	return undef unless $method_name =~ /^(instance\|get_instance\|singleton\|shared_instance)$/i;
8677
8678	7				10	my %singleton_info = (
8679						name_pattern => 1,
8680						);
8681
8682						# Look for singleton patterns in code
8683	7	50			10	if ($method_body) {
8684						# Pattern 1: Static/state variable holding instance
8685	7	100	67		29	if ($method_body =~ /(?:my\s+)?(?:our\s+)?\$(?:instance\|_instance\|singleton)\b/s \|\|
8686						$method_body =~ /state\s+\$(?:instance\|_instance\|singleton)\b/s) {
8687	5				6	$singleton_info{static_variable} = 1;
8688	5				9	$singleton_info{confidence} = 'high';
8689						}
8690
8691						# Pattern 2: Returns $instance if defined (with better regex)
8692	7	100	67		63	if ($method_body =~ /return\s+\$instance\s+if\s+(?:defined\s+)?\$instance/ \|\|
8693						$method_body =~ /unless\s+\$instance.?=\s.*?new/) {
8694	1				2	$singleton_info{returns_instance} = 1;
8695	1				1	$singleton_info{confidence} = 'high';
8696						}
8697
8698						# Pattern 3: \|\|= new() pattern (with better regex)
8699	7	100	67		30	if ($method_body =~ /\$instance\s\\|\\|=\s.*?new/ \|\|
8700						$method_body =~ /\$instance\s=\s.*?new\s+unless\s+(?:defined\s+)?\$instance/) {
8701	3				4	$singleton_info{lazy_initialization} = 1;
8702	3				5	$singleton_info{confidence} = 'medium';
8703						}
8704
8705						# Pattern 4: Direct return of $instance variable
8706	7	100			17	if ($method_body =~ /return\s+\$instance;/) {
8707	4				6	$singleton_info{returns_instance} = 1;
8708	4	50			8	$singleton_info{confidence} = 'high' unless $singleton_info{confidence};
8709						}
8710						}
8711
8712	7	50			18	return \%singleton_info if keys %singleton_info > 0; # Need at least name pattern
8713
8714	0				0	return undef;
8715						}
8716
8717						# --------------------------------------------------
8718						# _detect_instance_method
8719						#
8720						# Purpose: Detect whether a method is an
8721						# instance method that requires a
8722						# blessed object ($self) to be called,
8723						# through multiple detection patterns
8724						# of varying confidence.
8725						#
8726						# Entry: $method_name - method name string.
8727						# $method_body - method source string.
8728						#
8729						# Exit: Returns an instance_info hashref if
8730						# any instance method signal is found.
8731						# Returns undef if no signals are
8732						# detected.
8733						# The hashref may contain: explicit_self,
8734						# shift_self, uses_self,
8735						# accesses_object_data,
8736						# calls_instance_methods,
8737						# private_method, and confidence.
8738						#
8739						# Side effects: None.
8740						# --------------------------------------------------
8741						sub _detect_instance_method {
8742	322			322	2656	my ($self, $method_name, $method_body) = @_;
8743
8744	322				294	my %instance_info;
8745
8746						# Pattern 1: my ($self, ...) = @_;
8747	322	100 100 100 100			879	if ($method_body =~ /my\s\(\s\$self\s*[,)]/) {
8748	137				174	$instance_info{explicit_self} = 1;
8749	137				217	$instance_info{confidence} = 'high';
8750						}
8751
8752						# Pattern 1b: my $self = $_[0]; (direct-index style)
8753						elsif ($method_body =~ /my\s+\$self\s=\s\$_\[0\]/) {
8754	9				13	$instance_info{explicit_self} = 1;
8755	9				12	$instance_info{confidence} = 'high';
8756						}
8757
8758						# Pattern 2: my $self = shift;
8759						elsif ($method_body =~ /my\s+\$self\s=\sshift/) {
8760	18				32	$instance_info{shift_self} = 1;
8761	18				25	$instance_info{confidence} = 'high';
8762						}
8763
8764						# Pattern 3: Uses $self->something (including hash/array access)
8765						# This catches $self->{value} and $self->[0] as well as $self->method()
8766						elsif ($method_body =~ /\$self\s->\s(\w+\|[\{\[])/) {
8767	2				3	$instance_info{uses_self} = 1;
8768	2				3	$instance_info{confidence} = 'medium';
8769						}
8770
8771						# Pattern 4: Accesses object data: $self->{...}, $self->[...]
8772	322	100			545	if ($method_body =~ /\$self\s->\s[\{\[]/) {
8773	62				79	$instance_info{accesses_object_data} = 1;
8774	62	100			100	$instance_info{confidence} = 'high' unless $instance_info{confidence} eq 'high';
8775						}
8776
8777						# Pattern 5: Calls other instance methods on $self
8778	322	100			562	if ($method_body =~ /\$self\s->\s(\w+)\s*\(/s) {
8779	5				9	$instance_info{calls_instance_methods} = [];
8780	5				13	while ($method_body =~ /\$self\s->\s(\w+)\s*\(/g) {
8781	5 5				3 12	push @{$instance_info{calls_instance_methods}}, $1;
8782						}
8783	5 5	50			4 8	$instance_info{confidence} = 'high' if @{$instance_info{calls_instance_methods}};
8784						}
8785
8786						# Pattern 6: Method name suggests instance method (not perfect but helpful)
8787	322	100	67		458	if ($method_name =~ /^_/ && $method_name !~ /^_new/) {
8788						# Private methods are usually instance methods
8789	5				10	$instance_info{private_method} = 1;
8790	5	50			10	$instance_info{confidence} = 'low' unless exists $instance_info{confidence};
8791						}
8792
8793	322	100			466	return \%instance_info if keys %instance_info;
8794	151				151	return undef;
8795						}
8796
8797						# --------------------------------------------------
8798						# _check_inheritance_for_constructor
8799						#
8800						# Purpose: Determine whether the current package
8801						# uses an inherited constructor from a
8802						# parent class, by examining use parent,
8803						# use base, and @ISA declarations.
8804						#
8805						# Entry: $current_package - current package
8806						# name string.
8807						# $method_body - method source string
8808						# (checked for SUPER::
8809						# calls).
8810						#
8811						# Exit: Returns an inheritance_info hashref
8812						# if any inheritance information is
8813						# found, or undef otherwise.
8814						# The hashref may contain:
8815						# parent_statements, isa_array,
8816						# uses_super, calls_super_new,
8817						# has_own_constructor,
8818						# use_parent_constructor, parent_class.
8819						#
8820						# Side effects: None.
8821						# --------------------------------------------------
8822						sub _check_inheritance_for_constructor {
8823	163			163	12678	my ($self, $current_package, $method_body) = @_;
8824
8825	163				161	my $doc = $self->{_document};
8826	163	100			234	return undef unless $doc;
8827
8828	162				136	my %inheritance_info;
8829
8830						# 1. Look for parent/base statements
8831						my @parent_classes;
8832
8833						# Find all 'use parent' or 'use base' statements
8834	162		100		214	my $includes = $doc->find('PPI::Statement::Include') \|\| [];
8835	162				639140	foreach my $inc (@$includes) {
8836	311				322	my $content = $inc->content;
8837	311	100			2921	if ($content =~ /use\s+(parent\|base)\s+['"]?([\w:]+)['"]?/) {
8838	4				7	push @parent_classes, $2;
8839	4				6	$inheritance_info{parent_statements} = \@parent_classes;
8840						}
8841						# Also check for multiple parents: use parent qw(Class1 Class2)
8842	311	50			406	if ($content =~ /use\s+(parent\|base)\s+qw?[$\[]?(.+?)[$\]]?;/) {
8843	0				0	my $parents = $2;
8844	0				0	my @multi_parents = split /\s+/, $parents;
8845	0				0	push @parent_classes, @multi_parents;
8846	0				0	$inheritance_info{parent_statements} = \@parent_classes;
8847						}
8848						}
8849
8850						# 2. Look for @ISA assignments (with or without 'our')
8851	162		100		212	my $isas = $doc->find('PPI::Statement::Variable') \|\| [];
8852	162				638271	foreach my $isa (@$isas) {
8853	1005				873	my $content = $isa->content();
8854						# Match both "our @ISA = qw(...)" and "@ISA = qw(...)"
8855	1005	50			25734	if ($content =~ /(?:our\s+)?\@ISA\s=\sqw?[$\[]?(.+?)[$\]]?/) {
8856	0				0	my $parents = $1;
8857	0				0	my @isa_parents = split(/\s+/, $parents);
8858	0				0	push @parent_classes, @isa_parents;
8859	0				0	$inheritance_info{isa_array} = \@isa_parents;
8860						}
8861						}
8862
8863						# Also look for @ISA in regular statements
8864	162		50		202	my $statements = $doc->find('PPI::Statement') \|\| [];
8865	162				637526	foreach my $stmt (@$statements) {
8866	6315				4917	my $content = $stmt->content;
8867	6315	100			161388	if ($content =~ /\@ISA\s=\sqw?[$\[]?(.+?)[$\]]?/) {
8868	1				1	my $parents = $1;
8869	1				1	my @isa_parents = split(/\s+/, $parents);
8870	1				2	push @parent_classes, @isa_parents;
8871	1				2	$inheritance_info{isa_array} = \@isa_parents;
8872						}
8873						}
8874
8875						# 3. Check if method uses SUPER:: calls
8876	162	100	100		461	if ($method_body && $method_body =~ /SUPER::/) {
8877	2				3	$inheritance_info{uses_super} = 1;
8878	2	50			5	if ($method_body =~ /SUPER::new/) {
8879	0				0	$inheritance_info{calls_super_new} = 1;
8880						}
8881						}
8882
8883						# 4. Check if current package has its own new method
8884						my $has_own_new = $doc->find(sub {
8885	62077	100		62077	282734	$_[1]->isa('PPI::Statement::Sub') &&
8886						$_[1]->name eq 'new'
8887	162				386	});
8888
8889	162	100 100			1072	if ($has_own_new) {
8890	48				84	$inheritance_info{has_own_constructor} = 1;
8891						} elsif (@parent_classes) {
8892						# No own constructor, but has parents - might need parent constructor
8893	1				3	$inheritance_info{use_parent_constructor} = 1;
8894	1				2	$inheritance_info{parent_class} = $parent_classes[0]; # Use first parent
8895						}
8896
8897	162	100			304	return \%inheritance_info if keys %inheritance_info;
8898	113				278	return undef;
8899						}
8900
8901						# --------------------------------------------------
8902						# _detect_constructor_requirements
8903						#
8904						# Purpose: Analyse the new() method of the
8905						# current or target package to determine
8906						# what parameters the constructor
8907						# requires, including required and
8908						# optional parameters and their defaults.
8909						#
8910						# Entry: $current_package - the package being
8911						# analysed.
8912						# $target_package - the package whose
8913						# constructor will
8914						# be called (may
8915						# differ from current
8916						# for inherited
8917						# constructors).
8918						#
8919						# Exit: Returns a requirements hashref on
8920						# success, or undef if no new() method
8921						# is found. For external classes,
8922						# returns a minimal hashref with
8923						# external_class => 1.
8924						#
8925						# Side effects: None.
8926						# --------------------------------------------------
8927						sub _detect_constructor_requirements {
8928	164			164	16519	my ($self, $current_package, $target_package) = @_;
8929
8930	164				174	my $doc = $self->{_document};
8931	164	50			242	return undef unless $doc;
8932
8933						# If target is different from current, we can't analyze it
8934						# (external class, parent class in different file)
8935	164	100			210	if ($target_package ne $current_package) {
8936						return {
8937	1				6	external_class => 1,
8938						package => $target_package,
8939						note => "Constructor for external class $target_package - parameters unknown"
8940						};
8941						}
8942
8943						# Find the new method in current package
8944						my $new_method = $doc->find_first(sub {
8945	43458	100		43458	197463	$_[1]->isa('PPI::Statement::Sub') &&
8946						$_[1]->name eq 'new'
8947	163				372	});
8948
8949	163	100			1969	return undef unless $new_method;
8950
8951	49				42	my %requirements;
8952
8953						# Get method body
8954	49				57	my $body = $new_method->content;
8955
8956						# Look for parameter extraction patterns - handle both $self and $class
8957	49	100			4280	if ($body =~ /my\s$\s\$(self\|class)\s,\s(.+?)$\s=\s\@_/s) {
8958	40				56	my $params = $2;
8959	40				57	my @param_names = $params =~ /\$(\w+)/g;
8960
8961	40	100			54	if (@param_names) {
8962	3				6	$requirements{parameters} = \@param_names;
8963	3				8	$requirements{parameter_count} = scalar @param_names;
8964						}
8965						}
8966
8967						# Look for shift patterns
8968	49				36	my @shift_params;
8969	49				87	while ($body =~ /my\s+\$(\w+)\s=\sshift/g) {
8970	0				0	push @shift_params, $1;
8971						}
8972						# Remove $self or $class if present
8973	49 0				61 0	@shift_params = grep { $_ !~ /^(self\|class\|pkg\|proto\|klass)$/i } @shift_params;
8974
8975	49	50			61	if (@shift_params) {
8976	0				0	$requirements{parameters} = \@shift_params;
8977	0				0	$requirements{parameter_count} = scalar @shift_params;
8978	0				0	$requirements{shift_pattern} = 1;
8979						}
8980
8981						# Look for validation of parameters (more flexible pattern)
8982	49				29	my @required_params;
8983	49	100			99	if ($body =~ /croak.unless.(?:defined\s+)?\$(\w+)/g) {
8984	4				6	push @required_params, $1;
8985						}
8986	49	100			79	if ($body =~ /die.unless.(?:defined\s+)?\$(\w+)/g) {
8987	1				1	push @required_params, $1;
8988						}
8989
8990	49	100			58	if (@required_params) {
8991	5				10	$requirements{required_parameters} = \@required_params;
8992						}
8993
8994						# Look for default values (optional parameters)
8995	49				48	my @optional_params;
8996						my %default_values;
8997
8998						# Use the new _extract_default_value method
8999						# Check for each parameter in the constructor body
9000	49	100			58	if ($requirements{parameters}) {
9001	3 3				3 4	foreach my $param (@{$requirements{parameters}}) {
9002	5				13	my $default = $self->_extract_default_value($param, $body);
9003	5	100			8	if (defined $default) {
9004	2				2	push @optional_params, $param;
9005	2				5	$default_values{$param} = $default;
9006						}
9007						}
9008						}
9009
9010	49	100			52	if (@optional_params) {
9011	2				5	$requirements{optional_parameters} = \@optional_params;
9012	2				3	$requirements{default_values} = \%default_values;
9013						}
9014
9015	49	100			57	return \%requirements if keys %requirements;
9016	44				70	return undef;
9017						}
9018
9019
9020						# --------------------------------------------------
9021						# _detect_external_object_dependency
9022						#
9023						# Purpose: Detect whether a method creates or
9024						# depends on objects from classes other
9025						# than the current package, by scanning
9026						# for ->new() calls on named classes
9027						# and method calls on typed variables.
9028						#
9029						# Entry: $method_body - method source string.
9030						# May be undef.
9031						#
9032						# Exit: Returns a dependency_info hashref if
9033						# external object usage is found, or
9034						# undef otherwise.
9035						# The hashref may contain:
9036						# creates_objects (arrayref of class
9037						# names), uses_objects (arrayref of
9038						# class names), and package (the primary
9039						# dependency class).
9040						#
9041						# Side effects: None.
9042						# --------------------------------------------------
9043						sub _detect_external_object_dependency {
9044	160			160	4552	my ($self, $method_body) = @_;
9045
9046	160	100			158	return undef unless $method_body;
9047
9048	159				134	my %dependency_info;
9049
9050						# Pattern 1: Creates objects of other classes with ->new() or ->create()
9051						# Reset pos for global match
9052	159				212	pos($method_body) = 0;
9053	159				401	while ($method_body =~ /(\w+(?:::\w+)*)->(?:new\|create)\(/g) {
9054	5				6	my $class = $1;
9055	5	100	50		16	next if $class eq 'main' \|\| $class eq '__PACKAGE__' \|\| $class =~ /^\$/;
9056	4 4				3 23	push @{$dependency_info{creates_objects}}, $class;
9057						}
9058
9059	159	100			182	if ($dependency_info{creates_objects}) {
9060						# Remove duplicates
9061	3				2	my %seen;
9062	3 4 3				4 9 4	$dependency_info{creates_objects} = [grep { !$seen{$_}++ } @{$dependency_info{creates_objects}}];
9063	3				5	$dependency_info{package} = $dependency_info{creates_objects}[0];
9064						}
9065
9066						# Pattern 2: Calls methods on objects from other classes
9067	159	100			203	if ($method_body =~ /\$(\w+)->\w+\(/) {
9068	3				4	my %object_vars;
9069						# Reset pos for global match â€” the if check above used a
9070						# non-/g match so it cannot have advanced pos, but the while
9071						# loop's own /g matches still need to start from the beginning.
9072	3				3	pos($method_body) = 0;
9073	3				7	while ($method_body =~ /\$(\w+)->\w+\(/g) {
9074	4				9	$object_vars{$1}++;
9075						}
9076
9077						# Try to determine type of object variables
9078	3				1	my @object_classes;
9079	3				5	foreach my $var (keys %object_vars) {
9080						# Look for type declarations or assignments
9081	4	100 50			237	if ($method_body =~ /my\s+\$$var\s=\s(\w+(?:::\w+)+)->(?:new\|create)/) {
9082	3				8	push @object_classes, $1;
9083						} elsif ($method_body =~ /my\s+\$$var\s=\s(\w+(?:::\w+)+)->/) {
9084	0				0	push @object_classes, $1;
9085						}
9086						}
9087
9088	3	50			5	if (@object_classes) {
9089	3				4	$dependency_info{uses_objects} = \@object_classes;
9090	3	100			6	$dependency_info{package} = $object_classes[0] unless $dependency_info{package};
9091						}
9092						}
9093
9094						# Pattern 3: Receives objects as parameters (type hints in comments/POD)
9095						# This would need integration with parameter analysis
9096
9097	159	100			169	return \%dependency_info if keys %dependency_info;
9098	155				158	return undef;
9099						}
9100
9101						# --------------------------------------------------
9102						# _get_parent_class
9103						#
9104						# Purpose: Find the first parent class of the
9105						# current package by searching the
9106						# PPI document for use parent, use base,
9107						# or our @ISA declarations.
9108						#
9109						# Entry: None (operates on $self->{_document}).
9110						#
9111						# Exit: Returns the parent class name string,
9112						# or undef if no parent is found.
9113						#
9114						# Side effects: None.
9115						# --------------------------------------------------
9116						sub _get_parent_class {
9117	2			2	3453	my $self = $_[0];
9118
9119	2				2	my $doc = $self->{_document};
9120	2	50			3	return unless $doc;
9121
9122						# Look for use parent statements
9123						my $parent_stmt = $doc->find_first(sub {
9124	68	50	50	68	357	$_[1]->isa('PPI::Statement::Include') &&
9125						$_[1]->type eq 'use' &&
9126						$_[1]->module =~ /^(parent\|base)$/ &&
9127						$_[1]->arguments =~ /['"](\w+(?:::\w+)*)['"]/
9128	2				20	});
9129	2	50			15	if ($parent_stmt) {
9130	0				0	my $parent = $1;
9131	0				0	return $parent;
9132						}
9133
9134						# Look for @ISA assignment
9135						my $isa_stmt = $doc->find_first(sub {
9136	68	100		68	437	$_[1]->isa('PPI::Statement') &&
9137						$_[1]->content =~ /our\s+\@ISA\s=\s$\s['"](\w+(?:::\w+))['"]\s*$/
9138	2				3	});
9139	2	50	33		11	if ($isa_stmt && $isa_stmt->content =~ /['"](\w+(?:::\w+)*)['"]/) {
9140	0				0	return $1;
9141						}
9142
9143	2				3	return;
9144						}
9145
9146						# --------------------------------------------------
9147						# _get_class_for_instance_method
9148						#
9149						# Purpose: Determine which class should be used
9150						# for object instantiation when testing
9151						# an instance method, preferring the
9152						# current package if it has a new()
9153						# method, falling back to the parent
9154						# class otherwise.
9155						#
9156						# Entry: None (operates on $self->{_document}).
9157						#
9158						# Exit: Returns the package name string to
9159						# use for instantiation. Returns
9160						# 'UNKNOWN_PACKAGE' if no package
9161						# statement is found.
9162						#
9163						# Side effects: Stores the package name in
9164						# $self->{_package_name} if not
9165						# already set.
9166						# --------------------------------------------------
9167						sub _get_class_for_instance_method {
9168	2			2	3205	my $self = $_[0];
9169
9170						# Get the current package
9171	2				2	my $doc = $self->{_document};
9172	2				3	my $package_stmt = $doc->find_first('PPI::Statement::Package');
9173	2	100			370	return 'UNKNOWN_PACKAGE' unless $package_stmt;
9174	1				2	my $package_name = $package_stmt->namespace;
9175	1		33		14	$self->{_package_name} //= $package_name;
9176
9177						# Check if the current package has a 'new' method
9178						my $has_new = $doc->find(sub {
9179	46	100		46	253	$_[1]->isa('PPI::Statement::Sub') && $_[1]->name eq 'new'
9180	1				3	});
9181
9182	1	50			7	if ($has_new) {
9183	1				2	return $package_name;
9184						}
9185
9186						# Otherwise, try to get the parent class
9187	0				0	my $parent = $self->_get_parent_class();
9188	0	0			0	return $parent if $parent;
9189
9190						# Fallback to current package
9191	0				0	return $package_name;
9192						}
9193
9194						# --------------------------------------------------
9195						# _extract_default_value
9196						#
9197						# Purpose: Extract a default value for a named
9198						# parameter from a method body by
9199						# matching multiple common Perl default
9200						# assignment idioms.
9201						#
9202						# Entry: $param - parameter name string.
9203						# $code - method body source string.
9204						#
9205						# Exit: Returns the cleaned default value
9206						# scalar on success, or undef if no
9207						# default assignment pattern is found.
9208						#
9209						# Side effects: None.
9210						#
9211						# Notes: Eight patterns are tried in order:
9212						# \|\|, //=, defined ternary, unless
9213						# defined, \|\|=, //, multi-line if
9214						# !defined, unless defined block.
9215						# Comment lines are stripped from the
9216						# code before matching to avoid false
9217						# positives. Delegates to
9218						# _clean_default_value for value
9219						# normalisation.
9220						# --------------------------------------------------
9221						sub _extract_default_value {
9222	254			254	11169	my ($self, $param, $code) = @_;
9223
9224	254	100	100		494	return undef unless $param && $code;
9225
9226						# Clean up the code for easier pattern matching
9227						# Remove comments to avoid false positives
9228	251				220	my $clean_code = $code;
9229	251				408	$clean_code =~ s/#.*$//gm;
9230	251				2953	$clean_code =~ s/^\s+\|\s+$//g;
9231
9232						# Pattern 1: $param = $param \|\| 'default_value'
9233						# Also handles: $param = $arg \|\| 'default'
9234	251	100			8481	if ($clean_code =~ /\$$param\s=\s(?:\$$param\|\$[a-zA-Z_]\w)\s\\|\\|\s*([^;]+)/) {
9235	12				16	my $default = $1;
9236	12				11	$default =~ s/\s;\s$//;
9237	12				15	$default = $self->_clean_default_value($default);
9238	12	50			31	return $default if defined $default;
9239						}
9240
9241						# Pattern 2: $param //= 'default_value'
9242	239	100			2895	if ($clean_code =~ /\$$param\s\/\/=\s([^;]+)/) {
9243	10				13	my $default = $1;
9244	10				13	$default =~ s/\s;\s$//;
9245	10				13	$default = $self->_clean_default_value($default);
9246	10	100			27	return $default if defined $default;
9247						}
9248
9249						# Pattern 3: $param = defined $param ? $param : 'default'
9250						# Also handles: $param = defined $arg ? $arg : 'default'
9251	230	100			11526	if ($clean_code =~ /\$$param\s=\sdefined\s+(?:\$$param\|\$[a-zA-Z_]\w)\s\?\s(?:\$$param\|\$[a-zA-Z_]\w)\s:\s([^;]+)/) {
9252	6				9	my $default = $1;
9253	6				7	$default =~ s/\s;\s$//;
9254	6				7	$default = $self->_clean_default_value($default);
9255	6	50			16	return $default if defined $default;
9256						}
9257
9258						# Pattern 4: $param = 'default' unless defined $param;
9259	224	100			7371	if ($clean_code =~ /\$$param\s=\s([^;]+?)\s+unless\s+defined\s+(?:\$$param\|\$[a-zA-Z_]\w*)/) {
9260	3				5	my $default = $1;
9261	3				4	$default = $self->_clean_default_value($default);
9262	3	50			9	return $default if defined $default;
9263						}
9264
9265						# Pattern 5: $param \|\|= 'default'
9266	221	100			2674	if ($clean_code =~ /\$$param\s\\|\\|=\s([^;]+)/) {
9267	5				7	my $default = $1;
9268	5				9	$default =~ s/\s;\s$//;
9269	5				8	$default = $self->_clean_default_value($default);
9270	5	50			17	return $default if defined $default;
9271						}
9272
9273						# Pattern 6: $param = $arg // 'default'
9274	216	100			6311	if ($clean_code =~ /\$$param\s=\s(?:\$$param\|\$[a-zA-Z_]\w)\s\/\/\s*([^;]+)/) {
9275	2				2	my $default = $1;
9276	2				3	$default =~ s/\s;\s$//;
9277	2				3	$default = $self->_clean_default_value($default);
9278	2	100			4	return $default if defined $default;
9279						}
9280
9281						# Pattern 7: Multi-line: if (!defined $param) { $param = 'default'; }
9282	215	100			6282	if ($clean_code =~ /if\s$\s!defined\s+\$$param\s$\s\{[^}]\$$param\s=\s*([^;]+)/s) {
9283	1				2	my $default = $1;
9284	1				1	$default =~ s/\s;\s$//;
9285	1				2	$default = $self->_clean_default_value($default);
9286	1	50			5	return $default if defined $default;
9287						}
9288
9289						# Pattern 8: unless (defined $param) { $param = 'default'; }
9290	214	100			6080	if ($clean_code =~ /unless\s$\sdefined\s+\$$param\s$\s\{[^}]\$$param\s=\s*([^;]+)/s) {
9291	1				2	my $default = $1;
9292	1				1	$default =~ s/\s;\s$//;
9293	1				1	$default = $self->_clean_default_value($default);
9294	1	50			4	return $default if defined $default;
9295						}
9296
9297	213				569	return undef;
9298						}
9299
9300						# --------------------------------------------------
9301						# _extract_test_hints
9302						#
9303						# Purpose: Extract structured test hints from
9304						# a method's code and schema, including
9305						# boundary values, invalid inputs, and
9306						# valid input examples from POD.
9307						#
9308						# Entry: $method - method hashref.
9309						# $schema - schema hashref as built so
9310						# far by _analyze_method.
9311						#
9312						# Exit: Returns a hints hashref with keys:
9313						# boundary_values, invalid_inputs,
9314						# equivalence_classes, valid_inputs.
9315						# Keys with empty arrays are deleted
9316						# before returning.
9317						#
9318						# Side effects: None.
9319						# --------------------------------------------------
9320						sub _extract_test_hints {
9321	334			334	366	my ($self, $method, $schema) = @_;
9322
9323	334				743	my %hints = (
9324						boundary_values => [],
9325						invalid_inputs => [],
9326						equivalence_classes => [],
9327						valid_inputs => [],
9328						);
9329
9330	334				359	my $code = $method->{body};
9331	334	100			366	return {} unless $code;
9332
9333	333				563	$self->_extract_invalid_input_hints($code, \%hints);
9334	333				494	$self->_extract_boundary_value_hints($code, \%hints);
9335
9336						# prune empties
9337	333				447	for my $k (keys %hints) {
9338	1332 1332	100			793 1389	delete $hints{$k} unless @{$hints{$k}};
9339						}
9340
9341	333				400	return \%hints;
9342						}
9343
9344						# --------------------------------------------------
9345						# _extract_invalid_input_hints
9346						#
9347						# Purpose: Detect likely invalid input values
9348						# from a method body by looking for
9349						# defined checks, empty string checks,
9350						# and negative number checks.
9351						#
9352						# Entry: $code - method body source string.
9353						# $hints - hints hashref (modified in
9354						# place via invalid_inputs key).
9355						#
9356						# Exit: Returns nothing. Appends to
9357						# $hints->{invalid_inputs}.
9358						#
9359						# Side effects: None.
9360						# --------------------------------------------------
9361						sub _extract_invalid_input_hints {
9362	340			340	850	my ($self, $code, $hints) = @_;
9363
9364						# undef invalid
9365	340	100			472	if ($code =~ /defined\s\(\s\$/) {
9366	6 6				7 8	push @{ $hints->{invalid_inputs} }, 'undef';
9367						}
9368
9369						# empty string invalid
9370	340	100	100		730	if ($code =~ /\beq\s''/ \|\| $code =~ /\blength\s\(/) {
9371	12 12				12 18	push @{ $hints->{invalid_inputs} }, '';
9372						}
9373
9374						# negative number invalid
9375	340	100			536	if ($code =~ /\$\w+\s<\s0/) {
9376	8 8				7 12	push @{ $hints->{invalid_inputs} }, -1;
9377						}
9378						}
9379
9380						# --------------------------------------------------
9381						# _extract_boundary_value_hints
9382						#
9383						# Purpose: Extract numeric boundary values from
9384						# comparison operators in a method body,
9385						# adding both the boundary value and
9386						# the value one step either side.
9387						#
9388						# Entry: $code - method body source string.
9389						# $hints - hints hashref (modified in
9390						# place via boundary_values key).
9391						#
9392						# Exit: Returns nothing. Appends to and
9393						# deduplicates $hints->{boundary_values}.
9394						#
9395						# Side effects: None.
9396						# --------------------------------------------------
9397						sub _extract_boundary_value_hints {
9398	338			338	868	my ($self, $code, $hints) = @_;
9399
9400	338				938	while ($code =~ /\$\w+\s(<=\|<\|>=\|>)\s(\d+)/g) {
9401	29				50	my ($op, $n) = ($1, $2);
9402
9403	29	100 100 100 50			65	if ($op eq '<') {
9404	12 12				12 31	push @{ $hints->{boundary_values} }, $n, $n+1;
9405						} elsif ($op eq '<=') {
9406	2 2				2 6	push @{ $hints->{boundary_values} }, $n, $n+1;
9407						} elsif ($op eq '>') {
9408	13 13				14 116	push @{ $hints->{boundary_values} }, $n, $n-1;
9409						} elsif ($op eq '>=') {
9410	2 2				2 5	push @{ $hints->{boundary_values} }, $n, $n-1;
9411						}
9412						}
9413
9414						# Remove duplicates
9415	338				290	my %seen;
9416	338 58 338				271 116 530	$hints->{boundary_values} = [ grep { !$seen{$_}++ } @{ $hints->{boundary_values} } ];
9417						}
9418
9419						# --------------------------------------------------
9420						# _extract_pod_examples
9421						#
9422						# Purpose: Extract example method call patterns from a method's
9423						# SYNOPSIS section (=head1 or =head2) and from any
9424						# =for example begin/end blocks, and add them as
9425						# valid_inputs hints for fuzzing.
9426						#
9427						# Entry: $pod - POD string for the method. May be undef.
9428						# $hints - hints hashref (modified in place via the
9429						# valid_inputs key).
9430						#
9431						# Exit: Returns $hints. Appends to $hints->{valid_inputs}.
9432						#
9433						# Side effects: Logs the number of examples found to stdout when
9434						# verbose is set.
9435						#
9436						# Notes: For standalone runnable round-trip tests (not just
9437						# fuzzing hints) use App::Test::Generator::PodExampleExtractor
9438						# and bin/pod-example-tester instead.
9439						# --------------------------------------------------
9440						sub _extract_pod_examples {
9441	337			337	342	my ($self, $pod, $hints) = @_;
9442
9443	337	100			365	return $hints unless $pod;
9444
9445	137				102	my @examples;
9446
9447						# Accept both =head1 SYNOPSIS (module-level) and =head2 SYNOPSIS (method-level)
9448	137				111	my $synopsis = '';
9449	137	100			272	if($pod =~ /=head[12]\s+SYNOPSIS\s*(.+?)(?=\n=head\|\z)/s) {
9450	8				9	$synopsis = $1;
9451						}
9452
9453						# Also collect =for example begin ... =for example end blocks
9454	137				115	my @for_blocks;
9455	137				248	while($pod =~ /=for\s+example\s+begin(.+?)=for\s+example\s+end/sg) {
9456	1				3	push @for_blocks, $1;
9457						}
9458	137				169	$synopsis .= join('', @for_blocks);
9459
9460	137	100			205	return $hints unless length($synopsis);
9461
9462						# Constructor examples: ->wilma(foo => 'bar', count => 5)
9463	9				40	while ($synopsis =~ /->([a-z_0-9A-Z]+)\s$\s(.?)\s$/sg) {
9464	12				18	my ($method, $args) = ($1, $2);
9465	12				10	my %kv;
9466
9467	12				28	while ($args =~ /(\w+)\s=>\s(?:'([^'])'\|"([^"])"\|(\d+))/g) {
9468	10				9	my $key = $1;
9469	10	50 100			21	my $val = defined $2 ? $2 : defined $3 ? $3 : $4;
9470	10				18	$kv{$key} = $val;
9471						}
9472
9473	12	100			39	push @examples, {
9474						style => 'named',
9475						source => 'pod',
9476						args => \%kv,
9477						function => $method, # TODO: add a sanity check this is what we expect
9478						} if %kv;
9479						}
9480
9481	9	100			9	unless(scalar(@examples)) {
9482						# Positional calls: func($a, $b)
9483	4				25	while ($synopsis =~ /\b(\w+)\s$\s(.?)\s$/sg) {
9484	11				14	my ($func, $argstr) = ($1, $2);
9485
9486						# next if $func eq 'new'; # already handled
9487
9488	11 9				17 21	my @args = map { s/^\s+\|\s+$//gr } split /\s,\s/, $argstr;
9489
9490	11	100			16	next unless @args;
9491
9492	8				34	push @examples, {
9493						style => 'positional',
9494						source => 'pod',
9495						function => $func,
9496						args => \@args,
9497						};
9498						}
9499						}
9500
9501	9	50			11	if (scalar(@examples)) {
9502	9		100		17	$hints->{valid_inputs} \|\|= [];
9503	9 9				8 10	push @{ $hints->{valid_inputs} }, @examples;
9504
9505	9				18	$self->_log(" POD: extracted " . scalar(@examples) . " example call(s)");
9506						}
9507
9508	9				15	for my $k (qw(boundary_values invalid_inputs valid_inputs equivalence_classes)) {
9509	36		100		44	$hints->{$k} //= [];
9510						}
9511
9512	9				46	return $hints;
9513						}
9514
9515						# --------------------------------------------------
9516						# _clean_default_value
9517						#
9518						# Purpose: Normalise a raw default value string
9519						# extracted from code or POD into a
9520						# clean Perl scalar, handling quoted
9521						# strings, numeric literals, boolean
9522						# keywords, empty containers, and
9523						# undef.
9524						#
9525						# Entry: $value - raw value string.
9526						# May be undef.
9527						# $from_code - true if the value was
9528						# extracted from source
9529						# code (affects escape
9530						# sequence handling).
9531						#
9532						# Exit: Returns the cleaned value:
9533						# undef for undef or unparseable
9534						# {} for empty hashrefs
9535						# [] for empty arrayrefs
9536						# integer for whole numbers
9537						# float for decimal numbers
9538						# 1 or 0 for boolean keywords
9539						# string for everything else
9540						#
9541						# Side effects: None.
9542						# --------------------------------------------------
9543						sub _clean_default_value {
9544	177			177	217	my ($self, $value, $from_code) = @_;
9545
9546	177	100			185	return unless defined $value;
9547
9548						# Remove leading/trailing whitespace
9549	175				342	$value =~ s/^\s+\|\s+$//g;
9550
9551						# Remove parenthetical notes like "(no password)" only if there's content before them
9552	175				162	$value =~ s/(\S+)\s$[^)]+$\s$/$1/;
9553	175				263	$value =~ s/^\s+\|\s+$//g;
9554
9555						# Handle chained \|\| or // operators - extract the rightmost value
9556	175	100			350	if ($value =~ /\\|\\|\|\/{2}/) {
9557	7				26	my @parts = split(/\s(?:\\|\\|\|\/{2})\s/, $value);
9558	7				7	$value = $parts[-1];
9559	7				13	$value =~ s/^\s+\|\s+$//g;
9560						}
9561
9562						# Remove trailing semicolon if present
9563	175				157	$value =~ s/;\s*$//;
9564
9565						# Handle q{}, qq{}, qw{} quotes
9566	175	100 50 50			321	if ($value =~ /^qq?\{(.*?)\}$/s) {
9567	3				4	$value = $1;
9568						} elsif ($value =~ /^qw\{(.*?)\}$/s) {
9569	0				0	$value = $1;
9570						} elsif ($value =~ /^q[qwx]?\s([^a-zA-Z0-9\{\[])(.?)\1$/s) {
9571	0				0	$value = $2;
9572						}
9573
9574						# Handle quoted strings
9575	175	100			251	if ($value =~ /^(['"])(.*)\1$/s) {
9576	50				90	$value = $2;
9577
9578	50	100			54	if ($from_code) {
9579						# In regex captures from source code, escape sequences are doubled
9580						# \\n in capture needs to become \n for the test
9581	18				18	$value =~ s/\\\\/\\/g;
9582						}
9583
9584						# Only unescape the quote characters themselves
9585	50				49	$value =~ s/\\"/"/g;
9586	50				40	$value =~ s/\\'/'/g;
9587
9588						# If NOT from code (i.e., from POD), interpret escape sequences
9589	50	100			51	unless ($from_code) {
9590	32				28	$value =~ s/\\n/\n/g;
9591	32				29	$value =~ s/\\r/\r/g;
9592	32				26	$value =~ s/\\t/\t/g;
9593	32				27	$value =~ s/\\\\/\\/g;
9594						}
9595						}
9596
9597						# Sometimes trailing ) is left on
9598	175	100			190	if($value !~ /^\(/) {
9599	173				140	$value =~ s/\)$//;
9600						}
9601
9602						# Handle Perl empty hash (must be before numeric/boolean checks)
9603	175	100			205	if ($value =~ /^\{\s*\}$/) {
9604	6				12	return {};
9605						}
9606
9607						# Handle Perl empty list/array
9608	169	100			177	if ($value =~ /^\[\s*\]$/) {
9609	6				10	return [];
9610						}
9611
9612						# Handle numeric values
9613	163	100			305	if ($value =~ /^-?\d+(?:\.\d+)?$/) {
9614	68	100			75	if ($value =~ /\./) {
9615	11				35	return $value + 0;
9616						} else {
9617	57				109	return int($value);
9618						}
9619						}
9620
9621						# Handle boolean keywords
9622	95	100			148	if ($value =~ /^(true\|false)$/i) {
9623	9	100			29	return lc($1) eq 'true' ? 1 : 0;
9624						}
9625
9626						# Handle Perl boolean constants
9627	86	50 50			125	if ($value eq '1') {
9628	0				0	return 1;
9629						} elsif ($value eq '0') {
9630	0				0	return 0;
9631						}
9632
9633						# Handle undef
9634	86	100			96	if ($value eq 'undef') {
9635	12				20	return undef;
9636						}
9637
9638						# Handle __PACKAGE__ and similar constants
9639	74	100			78	if ($value eq '__PACKAGE__') {
9640	1				3	return '__PACKAGE__';
9641						}
9642
9643						# Remove surrounding parentheses
9644	73				74	$value =~ s/^$(.+)$$/$1/;
9645
9646						# Handle expressions we can't evaluate
9647	73	100	100		174	if ($value =~ /^\$[a-zA-Z_]/ \|\| $value =~ /$.*$/) {
9648	4	100			17	return if($value =~ /^\$\|\@\|\%/); # The default is a value, so who knows its type?
9649						# return $value;
9650						}
9651
9652	72				177	return $value;
9653						}
9654
9655						# --------------------------------------------------
9656						# _validate_pod_code_agreement
9657						#
9658						# Purpose: Compare POD parameter documentation
9659						# against code-inferred parameters and
9660						# return a list of disagreements when
9661						# strict_pod mode is enabled.
9662						#
9663						# Entry: $pod_params - hashref of parameters
9664						# from POD analysis.
9665						# $code_params - hashref of parameters
9666						# from code analysis.
9667						# $method_name - method name string,
9668						# used for context in
9669						# error messages.
9670						#
9671						# Exit: Returns a list of disagreement
9672						# strings. Returns an empty list if
9673						# all parameters agree.
9674						#
9675						# Side effects: None.
9676						#
9677						# Notes: Type mismatches are classified as
9678						# either 'compatible' (e.g. integer vs
9679						# number) or 'incompatible' via
9680						# _types_are_compatible. $self and
9681						# $class are excluded from undocumented
9682						# parameter warnings in appropriate
9683						# context.
9684						# --------------------------------------------------
9685						sub _validate_pod_code_agreement {
9686	23			23	1471	my ($self, $pod_params, $code_params, $method_name) = @_;
9687
9688	23				25	my @errors;
9689
9690						# Get all parameter names from both sources
9691	23 38				62 54	my %all_params = map { $_ => 1 } (keys %$pod_params, keys %$code_params);
9692
9693	23				49	foreach my $param (sort keys %all_params) {
9694	30		100		55	my $pod = $pod_params->{$param} \|\| {};
9695	30		100		44	my $code = $code_params->{$param} \|\| {};
9696
9697						# Params from a =head3\|4 Input formal spec are the authoritative API
9698						# definition â€” they are exempt from POD/code disagreement checks since
9699						# the spec takes precedence over heuristic code analysis.
9700	30	50			41	next if $pod->{_from_input_spec};
9701
9702						# Check if parameter exists in both
9703	30	100	100		89	if (exists $pod_params->{$param} && !exists $code_params->{$param}) {
9704	3				4	push @errors, "Parameter '\$$param' documented in POD but not found in code signature";
9705	3				4	next;
9706						}
9707
9708	27	50	67		46	if(!exists $pod_params->{$param} && exists $code_params->{$param}) {
9709	19	100			37	if($param =~ /^(class\|pkg\|proto\|klass)$/i) {
9710						# class invocant, not a user-facing parameter
9711	1				2	next;
9712						}
9713	18	100			26	if($param eq 'self') {
9714						# instance invocant, not a user-facing parameter
9715	1				2	next;
9716						}
9717	17				21	push @errors, "Parameter '\$$param' found in code but not documented in POD";
9718	17				24	next;
9719						}
9720
9721						# Compare types if both exist
9722	8	100	75		25	if ($pod->{type} && $code->{type} && $pod->{type} ne $code->{type}) {
9723	2	100			6	if (!$self->_types_are_compatible($pod->{type}, $code->{type})) {
9724	1				2	push @errors, "Type mismatch for '\$$param': POD says '$pod->{type}', code suggests '$code->{type}' (incompatible)";
9725						} else {
9726	1				2	push @errors, "Type difference for '\$$param': POD says '$pod->{type}', code suggests '$code->{type}' (compatible)";
9727						}
9728						}
9729
9730						# Compare optional status if both exist
9731	8	100	75		24	if (exists $pod->{optional} && exists $code->{optional} &&
9732						$pod->{optional} != $code->{optional}) {
9733	2	100			5	my $pod_status = $pod->{optional} ? 'optional' : 'required';
9734	2	100			4	my $code_status = $code->{optional} ? 'optional' : 'required';
9735	2				3	push @errors, "Optional status mismatch for '\$$param': POD says '$pod_status', code suggests '$code_status'";
9736						}
9737
9738						# Check constraints (min/max)
9739	8	0	25		12	if (defined $pod->{min} && defined $code->{min} && $pod->{min} != $code->{min}) {
9740	0				0	push @errors, "Min constraint mismatch for '\$$param': POD says '$pod->{min}', code suggests '$code->{min}'";
9741						}
9742
9743	8	0	25		12	if (defined $pod->{max} && defined $code->{max} && $pod->{max} != $code->{max}) {
9744	0				0	push @errors, "Max constraint mismatch for '\$$param': POD says '$pod->{max}', code suggests '$code->{max}'";
9745						}
9746
9747						# Check regex patterns
9748	8	0	25		12	if ($pod->{matches} && $code->{matches} && $pod->{matches} ne $code->{matches}) {
9749	0				0	push @errors, "Pattern mismatch for '\$$param': POD says '$pod->{matches}', code suggests '$code->{matches}'";
9750						}
9751						}
9752
9753						# Return errors (empty array if no errors)
9754	23				47	return @errors;
9755						}
9756
9757						# --------------------------------------------------
9758						# _validate_strictness_level
9759						#
9760						# Purpose: Validate and normalise the strict_pod
9761						# option value accepted by new() into
9762						# an integer level: 0 (off), 1 (warn),
9763						# or 2 (fatal).
9764						#
9765						# Entry: $val - the raw value passed to
9766						# strict_pod in new(). May be
9767						# undef, a number, or a string.
9768						#
9769						# Exit: Returns 0, 1, or 2.
9770						# Croaks if the value is not recognised.
9771						#
9772						# Side effects: None.
9773						# --------------------------------------------------
9774						sub _validate_strictness_level {
9775	504			504	12615	my $val = $_[0];
9776
9777	504	100			1551	return 0 unless defined $val;
9778
9779						# Numeric
9780	38	100			114	return 0 if $val =~ /^(0\|off\|none)$/i;
9781	29	100			100	return 1 if $val =~ /^(1\|warn\|warning)$/i;
9782	12	100			37	return 2 if $val =~ /^(2\|fatal\|die\|error)$/i;
9783
9784	2				11	croak("Invalid value for --strict-pod: '$val' (use off\|warn\|fatal)");
9785						}
9786
9787						# --------------------------------------------------
9788						# _types_are_compatible
9789						#
9790						# Purpose: Determine whether two type strings
9791						# are compatible for POD/code agreement
9792						# checking, allowing semantically
9793						# equivalent types (e.g. 'integer' and
9794						# 'number') to coexist without
9795						# triggering a strict POD warning.
9796						#
9797						# Entry: $pod_type - type string from POD.
9798						# $code_type - type string from code.
9799						#
9800						# Exit: Returns 1 if compatible, 0 otherwise.
9801						#
9802						# Side effects: None.
9803						# --------------------------------------------------
9804						sub _types_are_compatible {
9805	20			20	33	my ($self, $pod_type, $code_type) = @_;
9806
9807						# Exact match is always compatible
9808	20	100			29	return 1 if $pod_type eq $code_type;
9809
9810						# Define compatibility matrix
9811	15				40	my %compatible_types = (
9812						'integer' => ['number', 'scalar'],
9813						'number' => ['scalar'],
9814						'string' => ['scalar'],
9815						'scalar' => ['string', 'integer', 'number'],
9816						'arrayref' => ['array'],
9817						'hashref' => ['hash'],
9818						);
9819
9820						# Check if code_type is compatible with pod_type
9821	15	100			19	if (my $allowed = $compatible_types{$pod_type}) {
9822	13 17				14 38	return grep { $_ eq $code_type } @$allowed;
9823						}
9824
9825						# Check if pod_type is compatible with code_type
9826	2	50			3	if (my $allowed = $compatible_types{$code_type}) {
9827	2 2				4 5	return grep { $_ eq $pod_type } @$allowed;
9828						}
9829
9830	0				0	return 0; # Not compatible
9831						}
9832
9833 - 9882						=head2 generate_pod_validation_report Generate a human-readable report of all POD/code disagreements found across a set of extracted schemas. my $schemas = $extractor->extract_all(no_write => 1); my $report = $extractor->generate_pod_validation_report($schemas); print $report; =head3 Arguments =over 4 =item * C<$schemas> A hashref of method name to schema hashref as returned by C<extract_all>. Required. =back =head3 Returns A string containing the full validation report, or a single line confirming all methods passed if no disagreements were found. =head3 Side effects None. =head3 Notes Only methods whose schemas contain a C<_pod_validation_errors> key (populated when C<strict_pod> is 1 or 2) appear in the report. If C<strict_pod> was 0 when C<extract_all> was called, this method will always return the all-passed message. =head3 API specification =head4 input { self => { type => OBJECT, isa => 'App::Test::Generator::SchemaExtractor' }, schemas => { type => HASHREF }, } =head4 output { type => SCALAR } =cut
9883
9884						sub generate_pod_validation_report {
9885	17			17	1893	my ($self, $schemas) = @_;
9886
9887	17				13	my @reports;
9888	17				35	foreach my $method_name (sort keys %$schemas) {
9889	26				24	my $schema = $schemas->{$method_name};
9890
9891	26	100			30	if (my $errors = $schema->{_pod_validation_errors}) {
9892	16				25	push @reports, "Method: $method_name";
9893	16	100			25	push @reports, " Severity: " . ($schema->{_pod_disagreement} ? 'warning' : 'fatal');
9894	16				17	push @reports, " Errors:";
9895	16 16				16 22	push @reports, map { " - $_" } @$errors;
9896	16				18	push @reports, '';
9897						}
9898						}
9899
9900	17	100			23	if (@reports) {
9901	11				30	return join("\n", "POD/Code Validation Report:", '=' x 40, '', @reports);
9902						} else {
9903	6				9	return 'POD/Code Validation: All methods passed consistency checks.';
9904						}
9905						}
9906
9907 - 9911						=head2 _log Log a message if verbose mode is on. =cut
9912
9913						sub _log {
9914	5026			5026	6834	my($self, $msg) = @_;
9915
9916	5026	100			6537	print "$msg\n" if $self->{verbose};
9917						}
9918
9919 - 9961						=head1 NOTES C<SchemaExtractor> uses heuristic analysis of Perl source and POD to infer parameter types and constraints. Inference accuracy improves with well-documented modules; C<=head3 Input> / C<=head4 Input> formal specs are parsed at highest priority and override all heuristics. The output is always a best-effort schema suitable as a starting template; review and augment the generated YAML before using it as a definitive specification. Pass it to L<App::Test::Generator> to generate fuzz harnesses. =head1 TODO Extend C<=head4 Input> parsing to cover the C<enum>/C<memberof> constraint synonym (union types, e.g. C<scalar \| scalarref>, are already handled by C<_map_formal_input_type>). =head1 SEE ALSO =over 4 =item * L<App::Test::Generator> - Generate fuzz and corpus-driven test harnesses Output from this module serves as input to that module. So with well-documented code, you can automatically create your tests. =item * L<App::Test::Generator::Template> - Template of the file of tests created by C<App::Test::Generator> =back =head1 AUTHOR Nigel Horne, C<< <njh at nigelhorne.com> >> =head1 LICENCE AND COPYRIGHT Copyright 2025-2026 Nigel Horne. Usage is subject to GPL2 licence terms. If you use it, please let me know. =cut
9962
9963						1;