File Coverage

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

line	stmt	bran	cond	sub	time	code
1						package App::Test::Generator::SchemaExtractor;
2
3	34 34 34			34	1526153 39 454	use strict;
4	34 34 34			34	51 29 832	use warnings;
5	34 34 34			34	5577 177322 84	use autodie qw(:all);
6
7	34 34 34			34	248971 50 560	use App::Test::Generator::Model::Method;
8	34 34 34			34	5281 61 530	use App::Test::Generator::Analyzer::Complexity;
9	34 34 34			34	4891 48 463	use App::Test::Generator::Analyzer::Return;
10	34 34 34			34	4520 43 447	use App::Test::Generator::Analyzer::ReturnMeta;
11	34 34 34			34	4789 46 517	use App::Test::Generator::Analyzer::SideEffect;
12
13	34 34 34			34	62 30 722	use Carp qw(carp croak);
14	34 34 34			34	6296 1959404 635	use PPI;
15	34 34 34			34	6398 426178 573	use Pod::Simple::Text;
16	34 34 34			34	128 32 1474	use File::Basename;
17	34 34 34			34	73 34 713	use File::Path qw(make_path);
18	34 34 34			34	6300 91894 746	use Params::Get;
19	34 34 34			34	8087 146721 548	use Safe;
20	34 34 34			34	94 28 777	use Scalar::Util qw(looks_like_number);
21	34 34 34			34	4329 33114 905	use YAML::XS;
22	34 34 34			34	6867 39984 916	use IPC::Open3;
23	34 34 34			34	92 67 980	use JSON::MaybeXS qw(encode_json decode_json);
24	34 34 34			34	86 31 560	use Readonly;
25	34 34 34			34	60 33 759884	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	486			486	3279008	my $class = shift;
1353
1354						# Handle hash or hashref arguments
1355	486		50		1235	my $params = Params::Get::get_params('input_file', @_) \|\| {};
1356
1357	483	50			7912	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	483		50 100 100 67 67		3123	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	483	100			3921	unless (-f $self->{input_file}) {
1374	3				73	croak(__PACKAGE__, ": Input file '$self->{input_file}' does not exist");
1375						}
1376
1377	480				1147	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	112			112	3677	my $self = shift;
1457	112		100		201	my $params = Params::Get::get_params(undef, @_) \|\| {};
1458
1459	112				1499	$self->_log("Parsing $self->{input_file}...");
1460	112				317	$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	112	50			669	or croak "Failed to parse $self->{input_file}";
1465
1466						# Store document for later use
1467	112				1023695	$self->{_document} = $document;
1468
1469	112				417	my $package_name = $self->_extract_package_name($document);
1470	112		67		1101	$self->{_package_name} //= $package_name;
1471	112				334	$self->_log("Package: $package_name");
1472
1473	112				300	my $methods = $self->_find_methods($document);
1474	112				333	$self->_log('Found ' . scalar(@$methods) . ' methods (pre-dedup)');
1475
1476	112				125	my %schemas;
1477	112 112				118 160	foreach my $method (@{$methods}) {
1478	329				738	$self->_log("\nAnalyzing method: $method->{name}");
1479
1480	329				643	my $schema = $self->_analyze_method($method);
1481	328				667	$schemas{$method->{name}} = $schema;
1482	328				500	$schema->{'module'} = $package_name;
1483
1484						# Write individual schema file
1485						# Only write schema files if no_write is not set
1486	328	100			949	$self->_write_schema($method->{name}, $schema) unless $params->{no_write};
1487						}
1488
1489	111				770	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	135			135	3636	my ($self, $document) = @_;
1516
1517	135	100			289	if(!defined($document)) {
1518	21				31	$document = $self->{_document};
1519						}
1520	135		100		355	my $pkgs = $document->find('PPI::Statement::Package') \|\| [];
1521	135	100			312067	if(@$pkgs == 0) {
1522	8				23	my $package_stmt = $document->find_first('PPI::Statement::Package');
1523	8	50			9247	return $package_stmt ? $package_stmt->namespace() : '';
1524						}
1525	127	50			254	croak('More than one package declaration found') if @$pkgs > 1;
1526	127		67		581	$self->{_package_name} //= $pkgs->[0]->namespace();
1527	127				1655	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	118			118	35631	my ($self, $document) = @_;
1561
1562	118		100		199	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	21486			21486	147821	$_[1]->isa('PPI::Statement')
1568						&& $_[1]->content =~ /^\s*(?:before\|after\|around)\b/
1569	118		50		226699	}) \|\| [];
1570
1571	118				887	my @methods;
1572	118				187	foreach my $sub (@$subs) {
1573	355				16964	my $name = $sub->name();
1574
1575	355	50			8110	next unless defined $name; # Skip anonymous routines
1576	355	100			520	next if $name =~ /^(BEGIN\|END\|DESTROY\|AUTOLOAD\|CHECK\|INIT\|UNITCHECK)$/;
1577	353	50			488	next if $name =~ /::/; # cross-package sub (e.g. sub DB::DB { })
1578
1579						# Skip private methods unless explicitly included, or they're special
1580	353	100	100		586	if ($name =~ /^_/ && $name !~ /^_(new\|init\|build)/) {
1581	14	100			30	next unless $self->{include_private};
1582						}
1583
1584						# Get the POD before this sub
1585	342				525	my $pod = $self->_extract_pod_before($sub);
1586
1587	342				442	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	118				8133	my $content = $document->content();
1598	118	100			29281	if ($content =~ /\bclass\b/) {
1599	26				62	$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	26				449	(my $code_only = $content) =~ s/^=\w[^\n].?^=cut[^\n]*\n//gms;
1605	26				309	$code_only =~ s/\s#[^\n]//g;
1606	26				94	$self->_extract_class_methods($code_only, \@methods);
1607						}
1608
1609						# Process method modifiers (Moose)
1610	118				216	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	118				129	my %seen;
1640						@methods = grep {
1641	118 343				200 318	my $n = $_->{name};
1642	343	100			580	if ($seen{$n}++) {
1643	1				2	$self->_log(" WARNING: duplicate method '$n' ignored");
1644	1				3	0;
1645						} else {
1646	342				382	1;
1647						}
1648						} @methods;
1649
1650	118				313	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	27			27	60	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	27				157	while ($content =~ /class\s+(\w+)\s*\{/g) {
1687	2				4	my $class_name = $1;
1688	2				3	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				11	require Text::Balanced;
1694	2				10	my $extracted = Text::Balanced::extract_bracketed(substr($content, $start_pos - 1), '{}');
1695
1696	2	50			692	next unless defined $extracted; # unbalanced braces, skip class
1697
1698	2				4	my $class_body = substr($extracted, 1, length($extracted) - 2);
1699
1700	2				7	$self->_log(" Found class $class_name");
1701
1702						# Extract field declarations from class
1703	2				8	my $fields = $self->_extract_field_declarations($class_body);
1704
1705						# Find methods in the class body
1706	2				11	while ($class_body =~ /method\s+(\w+)\s($[^)]$)?\s*\{/g) {
1707	2		50		6	my ($method_name, $sig_with_parens) = ($1, $2 \|\| '()');
1708
1709						# Skip private unless configured
1710	2	50	33		7	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				3	my $signature = $sig_with_parens;
1716	2				5	$signature =~ s/^\(//;
1717	2				5	$signature =~ s/\)$//;
1718
1719						# Build a fake sub declaration
1720	2				4	my $fake_sub = "sub $method_name($signature) { }";
1721
1722	2				12	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				5	$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	344			344	4061	my ($self, $sub) = @_;
1766
1767	344				302	my $pod = '';
1768	344				552	my $current = $sub->previous_sibling();
1769	344				4979	my $seen_code = 0;
1770	344				279	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	344		67		955	while($current && $steps++ < $POD_WALK_LIMIT) {
1776	865	100 100 100 100	67		8228	if ($current->isa('PPI::Token::Pod')) {
1777	134				137	$pod = $current->content() . $pod;
1778	134				287	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				33	my $comment = $current->content();
1782	34	50			75	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				182	last;
1793						}
1794	525				528	$current = $current->previous_sibling();
1795						}
1796
1797	344				378	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	329			329	412	my ($self, $method) = @_;
1839	329				454	my $code = $method->{body};
1840	329				388	my $pod = $method->{pod};
1841
1842						# Extract modern features
1843	329				802	my $attributes = $self->_extract_subroutine_attributes($code);
1844	329				704	my $postfix_derefs = $self->_analyze_postfix_dereferencing($code);
1845	329				722	my $fields = $self->_extract_field_declarations($code);
1846
1847						# If this method came from a class, use those field declarations
1848	329 1	50	67		620 3	if ($method->{fields} && keys %{$method->{fields}}) {
1849	1				2	$fields = $method->{fields};
1850						}
1851
1852						my $schema = {
1853						function => $method->{name},
1854	329				1476	_confidence => {
1855						'input' => {},
1856						'output' => {}
1857						},
1858						input => {},
1859						output => {},
1860						setup => undef,
1861						transforms => {},
1862						};
1863
1864						# Analyze different sources
1865	329				924	my $pod_params = $self->_analyze_pod($pod);
1866	329				794	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	329	100	67		701	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				61	ignore_self => 1,
1878						allow_renames => 1,
1879						}
1880						);
1881
1882	12	100			28	if (@validation_errors) {
1883	11				29	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				22	$schema->{_pod_validation_errors} = \@validation_errors;
1888
1889						# Either croak immediately or log based on configuration
1890	11	100			37	if($self->{strict_pod} == $STRICT_POD_FATAL) {
1891	1				19	croak("[POD STRICT] $error_msg");
1892						} else { # 1 = warnings
1893	10				992	carp("[POD STRICT] $error_msg");
1894						# Continue with analysis, but mark as problematic
1895	10				933	$schema->{_pod_disagreement} = 1;
1896						}
1897						}
1898	11				23	$schema->{_strict_pod_level} = $self->{strict_pod};
1899						}
1900
1901	328				759	my $validator_params = $self->_extract_validator_schema($code);
1902
1903	328	100			483	if ($validator_params) {
1904	5				11	$schema->{input} = $validator_params->{input};
1905	5				11	$schema->{input_style} = 'hash';
1906	5				19	$schema->{_confidence}{input} = { 'factors' => [ 'Determined from validator' ], 'level' => 'high' };
1907						$schema->{_analysis}{confidence_factors}{input} = [
1908	5				12	'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				12	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	323	100			545	if (keys %$fields) {
1927	1				3	$self->_merge_field_declarations($code_params, $fields);
1928						}
1929
1930						# Merge analyses
1931	323				787	$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	328				1027	);
1946
1947
1948						# Detect accessor methods
1949	328				904	$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	328				827	my $needs_object = $self->_needs_object_instantiation($method->{name}, $method->{body}, $method);
1954	328	100	100		974	if($method->{name} ne 'new' && $needs_object) {
1955	157				376	$schema->{new} = $needs_object;
1956	157				434	$self->_log(" NEW: Method requires object instantiation: $needs_object");
1957						}
1958
1959						# Calculate confidences
1960	328				514	my $input_confidence = $schema->{_confidence}{'input'};
1961	328	50			570	if(!ref($input_confidence)) {
1962	0				0	$input_confidence = $schema->{_confidence}{'input'} = $self->_calculate_input_confidence($schema->{input});
1963						}
1964	328				928	my $output_confidence = $schema->{_confidence}{'output'} = $self->_calculate_output_confidence($schema->{output});
1965
1966						# Add metadata
1967	328				936	$schema->{_notes} = $self->_generate_notes($schema->{input});
1968
1969						# Add analytics
1970	328		100		945	$schema->{_analysis} \|\|= {};
1971	328				551	$schema->{_analysis}{input_confidence} = $input_confidence->{level};
1972	328				502	$schema->{_analysis}{output_confidence} = $output_confidence->{level};
1973	328		100		852	$schema->{_analysis}{confidence_factors} \|\|= {};
1974	328		100		941	$schema->{_analysis}{confidence_factors}{input} \|\|= $input_confidence->{factors};
1975	328		33		808	$schema->{_analysis}{confidence_factors}{output} \|\|= $output_confidence->{factors};
1976
1977	328				434	foreach my $mode('input', 'output') {
1978	656				955	$self->_set_defaults($schema, $mode);
1979						}
1980
1981						# Optionally store detailed per-parameter analysis
1982	328	50			431	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	328				354	my $input_level = $input_confidence->{level};
1988	328				309	my $output_level = $output_confidence->{level};
1989
1990	328				1031	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	328		100		783	$input_level //= 'none';
2000	328		50		387	$output_level //= 'none';
2001	328	100			634	my $overall = $level_rank{$input_level} < $level_rank{$output_level} ? $input_level : $output_level;
2002
2003	328				439	$schema->{_analysis}{overall_confidence} = $overall;
2004
2005						# Analyze parameter relationships
2006	328				731	my $relationships = $self->_analyze_relationships($method);
2007	328 328	100	67		569 524	if ($relationships && @{$relationships}) {
2008	7				14	$schema->{relationships} = $relationships;
2009	7				16	$self->_log(" Found " . scalar(@$relationships) . " parameter relationships");
2010						}
2011
2012						# Store modern feature info in schema
2013	328	100			575	$schema->{_attributes} = $attributes if keys %$attributes;
2014	328	100			498	$schema->{_modern_features}{postfix_dereferencing} = $postfix_derefs if keys %$postfix_derefs;
2015	328	100			403	$schema->{_fields} = $fields if keys %$fields;
2016
2017						# Store class info if this is a class method
2018	328	100			483	if ($method->{class}) {
2019	1				1	$schema->{_class} = $method->{class};
2020						}
2021
2022	328				848	my $hints = $self->_extract_test_hints($method, $schema);
2023	328				707	$self->_extract_pod_examples($pod, $hints);
2024
2025	328				453	for my $k (qw(boundary_values invalid_inputs valid_inputs equivalence_classes)) {
2026	1312				1004	my %seen;
2027						$hints->{$k} = [
2028	70	50			164	grep { !$seen{ defined $_ ? $_ : '__undef__' }++ }
2029	1312 1312				821 1711	@{ $hints->{$k} }
2030						];
2031						}
2032
2033						# --------------------------------------------------
2034						# YAML test hints: numeric boundaries
2035						# --------------------------------------------------
2036	328	100			732	if ($self->_method_has_numeric_intent($schema)) {
2037	155		50		422	$schema->{_yamltest_hints} \|\|= {};
2038
2039						# Do not override existing hints
2040	155		50		390	$schema->{_yamltest_hints}{boundary_values} \|\|= [];
2041
2042	0	0			0	my %seen = map { (defined $_ ? $_ : '__undef__') => 1 }
2043	155 155				144 303	@{ $schema->{_yamltest_hints}{boundary_values} };
2044
2045	155 155				138 268	foreach my $v (@{ $self->_numeric_boundary_values }) {
2046	774	100			631	my $key = defined $v ? $v : '__undef__';
2047	774 774	50			1036 679	push @{ $schema->{_yamltest_hints}{boundary_values} }, $v unless $seen{$key}++;
2048						}
2049
2050	155				228	$self->_log(' HINTS: Added numeric boundary values');
2051						}
2052
2053	328	50			476	if (keys %$hints) {
2054	328		100		672	$schema->{_yamltest_hints} \|\|= {};
2055	328				454	foreach my $k (keys %$hints) {
2056						$schema->{_yamltest_hints}{$k} = $hints->{$k}
2057	1312	100			1587	unless exists $schema->{_yamltest_hints}{$k};
2058						}
2059						}
2060
2061	328	100	100		735	if(($level_rank{$overall} < $level_rank{$LEVEL_MEDIUM}) &&
2062						($level_rank{$overall} < ($self->{confidence_threshold} * 4))) {
2063	275				1623	$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	328				2248	);
2074
2075	328				1422	my $return_analyzer = App::Test::Generator::Analyzer::Return->new();
2076	328				785	$return_analyzer->analyze($method_model);
2077
2078						# Let model learn from finalized schema
2079	328	50			458	if ($schema->{output}) {
2080	328				853	$method_model->absorb_legacy_output($schema->{output});
2081						}
2082
2083	328				760	$method_model->resolve_return_type();
2084	328				670	$method_model->resolve_classification();
2085	328				626	$method_model->resolve_confidence();
2086
2087						# Attach only metadata
2088						$schema->{_model} = {
2089	328				707	classification => $method_model->classification,
2090						confidence => $method_model->confidence,
2091						};
2092
2093						# ----------------------------------------
2094						# Return Meta Analysis (Non-invasive)
2095						# ----------------------------------------
2096
2097	328				1200	my $meta = App::Test::Generator::Analyzer::ReturnMeta->new();
2098	328				707	my $analysis = $meta->analyze($schema);
2099
2100	328				452	$schema->{_analysis}{stability_score} = $analysis->{stability_score};
2101	328				395	$schema->{_analysis}{consistency_score} = $analysis->{consistency_score};
2102	328				449	$schema->{_analysis}{risk_flags} = $analysis->{risk_flags};
2103
2104						# ----------------------------------------
2105						# Side Effect Analysis (Non-invasive)
2106						# ----------------------------------------
2107
2108	328				1118	my $se = App::Test::Generator::Analyzer::SideEffect->new();
2109
2110	328				643	my $effects = $se->analyze($method);
2111
2112	328				435	$schema->{_analysis}{side_effects} = $effects;
2113
2114						# ----------------------------------------
2115						# Complexity Analysis (Non-invasive)
2116						# ----------------------------------------
2117
2118	328				1091	my $cx = App::Test::Generator::Analyzer::Complexity->new();
2119	328				650	my $complexity = $cx->analyze($method);
2120
2121	328				419	$schema->{_analysis}{complexity} = $complexity;
2122
2123	328				2406	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	332			332	421	my ($self, $schema) = @_;
2146
2147						# Numeric output
2148	332	100	75		1735	return 1 if ($schema->{output} && $schema->{output}{type} && $schema->{output}{type} =~ /^(number\|integer)$/);
2149
2150						# Numeric inputs
2151	194 194	100			231 441	foreach my $p (values %{ $schema->{input} \|\| {} }) {
2152	163	100			295	next if $p->{optional};
2153	62	100	67		275	return 1 if ($p->{type} && $p->{type} =~ /^(number\|integer)$/);
2154						}
2155
2156	174				300	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	308	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	333			333	1531	my ($self, $method, $schema) = @_;
2212
2213	333				411	my $body = $method->{body};
2214
2215						# Normalize whitespace for regex sanity
2216	333				305	my $code = $body;
2217	333				1905	$code =~ s/\s+/ /g;
2218
2219						# If a method touches more than one $self->{...}, itâ€™s not an accessor.
2220	333				413	my %fields_seen;
2221	333				1294	while ($code =~ /\$self\s->\s\{\s['"]?([^}'"]+)['"]?\s\}/g) {
2222	93				193	$fields_seen{$1}++;
2223						}
2224	333	100			609	if (keys(%fields_seen) > 1) {
2225	4				8	$self->_log(" Skipping accessor detection: multiple fields accessed");
2226	4				6	return;
2227						}
2228
2229						# -------------------------------
2230						# Getter/Setter combo
2231						# -------------------------------
2232	329	50 100 100 100	50 75 100		2741	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				11	my $property = $1;
2288
2289	7	50			15	if(!defined($property)) {
2290	7	50			28	if($code =~ /\$self\s->\s\{\s['"]?([^}'"]+)['"]?\s\}\s*=/) {
2291	7				9	$property = $1;
2292						}
2293						}
2294	7	100			19	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			11	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		12	value => { type => 'string', optional => 1 },
2320						};
2321						}
2322						};
2323						$schema->{accessor} = {
2324	7				21	type => 'getset',
2325						property => $property,
2326						};
2327
2328	7				30	$self->_log(" Detected getter/setter accessor for property: $property");
2329	7	100			13	if (my $pod = $method->{pod}) {
2330	2	50			7	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			24	if(ref($schema->{input}) eq 'HASH') {
2355	7 7				12 12	my @input_keys = keys %{$schema->{input}};
2356	7	50 50			18	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				42	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			1377	if($code !~ /\$self\s->\s\{\s['"]?\Q$property\E['"]?\s\}\s=\s(?:shift\|\$\w+\s=\sshift\|\@_\|\$_\[\d+\])/) {
2378	24				70	my @returns = $code =~ /return\b/g;
2379	24				481	my @self_returns = $code =~ /return\s+\$self\s->\s\{\s['"]?\Q$property\E['"]?\s\}/g;
2380						# it's a getter
2381	24	100			52	if (scalar(@returns) == scalar(@self_returns)) {
2382						# all returns are returning $self->{$property}, so it's a getter
2383						$schema->{accessor} = {
2384	22				74	type => 'getter',
2385						property => $property,
2386						};
2387
2388	22				50	$self->_log(" Detected getter accessor for property: $property");
2389
2390						$schema->{_confidence}{output} = {
2391	22				70	level => 'high',
2392						factors => ['Detected getter method'],
2393						};
2394	22				52	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				12	my ($property, $param) = ($1, $2);
2405
2406						$schema->{accessor} = {
2407	6				27	type => 'setter',
2408						property => $property,
2409						param => $param,
2410						};
2411
2412	6				33	$self->_log(" Detected setter accessor for property: $property");
2413
2414						$schema->{input} = {
2415	6				18	$param => { type => 'string' }, # safe default
2416						};
2417	6				15	$schema->{input_style} = 'hash';
2418
2419						$schema->{_confidence}{input} = {
2420	6				20	level => 'high',
2421						factors => ['Detected setter/accessor method'],
2422						};
2423	6	100 50			22	if($schema->{output}{_returns_self}) {
2424	5	50			26	if($schema->{output}{type} ne 'object') {
2425	0				0	croak 'Setter can not return data other than $self';
2426						}
2427	5	50			14	if($schema->{output}{isa} ne $self->{_package_name}) {
2428	0				0	croak 'Setter can not return data other than $self';
2429						}
2430	1				4	} 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	329	100			644	if(exists($schema->{accessor})) {
2439	35	50	50		224	if($schema->{accessor}{type} && $schema->{accessor}{type} =~ /setter\|getset/ && $schema->{input}) {
2440	13 13				16 30	for my $param (keys %{ $schema->{input} }) {
2441	13				18	my $in = $schema->{input}{$param};
2442
2443	13	100	100		53	if ($in->{type} && ($in->{type} eq 'object')) {
2444						$schema->{output} = {
2445						type => 'object',
2446	2	50			6	($in->{isa} ? (isa => $in->{isa}) : ()),
2447						};
2448
2449						$schema->{_confidence}{output} = {
2450	2				5	level => 'high',
2451						factors => ['Output type propagated from setter input'],
2452						};
2453						}
2454						}
2455						}
2456
2457	35	100	67		312	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			61	if (my $pod = $method->{pod}) {
2460						# POD says "UserAgent object"
2461	12	100			51	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 3	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	3238	my ($self, %args) = @_;
2491
2492	2		100		7	my $method = $args{method} // 'UNKNOWN';
2493	2		100		9	my $msg = $args{message} // 'Analysis error';
2494
2495	2		100		8	my $module = $self->{_package_name} // 'UNKNOWN';
2496	2		100		6	my $file = $self->{input_file} // 'UNKNOWN';
2497
2498	2				20	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	333			333	430	my ($self, $code) = @_;
2533
2534	333				475	for my $extractor ('_extract_pvs_schema', '_extract_pv_schema', '_extract_moosex_params_schema', '_extract_type_params_schema') {
2535	1317				2756	my $res = $self->$extractor($code);
2536	1317 7	50 50	50		4507 27	return $res if ($res && ref($res) eq 'HASH' && keys %{ $res->{input} \|\| {} });
2537						}
2538
2539	326				442	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	1112	my ($self, $hash) = @_;
2565
2566	1				2	my %result;
2567
2568	1				6	for my $child ($hash->children) {
2569						# skip whitespace and operators
2570	1	50	33		11	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				6	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	5449	my ($self, $code) = @_;
2657
2658	29	100	67		89	return $code if ref($code) && $code->can('find');
2659
2660	28		100		107	$self->{_ppi_cache} \|\|= {};
2661	28		67		189	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	341			341	450	my ($self, $code) = @_;
2683
2684	341	100			818	return unless $code =~ /\bvalidate_strict\s*\(/;
2685
2686	9	50			27	my $doc = $self->_ppi($code) or return;
2687
2688						my $calls = $doc->find(sub {
2689	954	100	100	954	4509	$_[1]->isa('PPI::Token::Word') && ($_[1]->content eq 'validate_strict' \|\| $_[1]->content eq 'Params::Validate::Strict::validate_strict')
2690	9	50			46643	}) or return;
2691
2692	9				78	for my $call (@$calls) {
2693	9				35	my $list = $call->parent();
2694	9		67		197	while ($list && !$list->isa('PPI::Structure::List')) {
2695	40				248	$list = $list->parent();
2696						}
2697	9	50			27	if(!defined($list)) {
2698	9				34	my $next = $call->next_sibling();
2699	9	50			262	next unless defined $next;
2700	9	100			19	if($next->content() =~ /schema\s=>\s(\{(?:[^{}]\|\{(?:[^{}]\|\{[^{}]\})\})*\})/s) {
2701	7				1038	my $schema_text = $1;
2702	7	50			35	next if $schema_text =~ $UNSAFE_KEYWORD_RE;
2703	7				85	my $compartment = Safe->new();
2704	7				3339	$compartment->permit_only(qw(:base_core :base_mem :base_orig));
2705
2706	7				41	my $schema_str = "my \$schema = $schema_text";
2707	7				22	my $schema = $compartment->reval($schema_str);
2708	7 7	50			2397 15	if(scalar keys %{$schema}) {
2709						return {
2710	7				36	input => $schema,
2711						style => 'hash',
2712						source => 'validator'
2713						}
2714						}
2715						}
2716						}
2717	2	50			115	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				4	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	339			339	475	my ($self, $code) = @_;
2748
2749	339	100			815	return unless $code =~ /\bvalidate\s*\(/;
2750
2751	8	50			22	my $doc = $self->_ppi($code) or return;
2752
2753						my $calls = $doc->find(sub {
2754	689	100	100	689	3268	$_[1]->isa('PPI::Token::Word') && ($_[1]->content eq 'validate' \|\| $_[1]->content eq 'Params::Validate::validate')
2755	8	50			33517	}) or return;
2756
2757	8				71	for my $call (@$calls) {
2758	8				29	my $list = $call->parent;
2759	8		67		152	while ($list && !$list->isa('PPI::Structure::List')) {
2760	30				171	$list = $list->parent;
2761						}
2762	8	50			48	if(!defined($list)) {
2763	8				27	my $next = $call->next_sibling();
2764	8				253	my ($arglist, $schema_text) = $self->_parse_pv_call($next);
2765
2766	8	50	33		39	if($schema_text && $schema_text !~ $UNSAFE_KEYWORD_RE) {
2767	8				108	my $compartment = Safe->new();
2768	8				3757	$compartment->permit_only(qw(:base_core :base_mem :base_orig));
2769
2770	8				45	my $schema_str = "my \$schema = $schema_text";
2771	8				23	my $schema = $compartment->reval($schema_str);
2772
2773	8 8	100			2571 19	if(scalar keys %{$schema}) {
2774	7 7				7 11	foreach my $arg(keys %{$schema}) {
2775	12				13	my $field = $schema->{$arg};
2776	12	50			24	if(my $type = $field->{'type'}) {
2777	12	100 50			23	if($type eq 'ARRAYREF') {
2778	1				2	$field->{'type'} = 'arrayref';
2779						} elsif($type eq 'SCALAR') {
2780	11				14	$field->{'type'} = 'string';
2781						}
2782						}
2783	12				27	delete $field->{'callbacks'};
2784						}
2785
2786						return {
2787	7				37	input => $schema,
2788						style => 'hash',
2789						source => 'validator'
2790						}
2791						}
2792						}
2793						}
2794	1	50			48	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				3	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	46	my ($self, $string) = @_;
2828
2829						# Remove outer parentheses and whitespace
2830	21				50	$string =~ s/^\s\(\s//;
2831	21				2764	$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				1062	require Text::Balanced;
2837	21				8381	my $rest = $string;
2838	21				26	my $comma_pos = 0;
2839	21				23	my $found_comma = 0;
2840
2841	21				43	while (length $rest) {
2842	93	100			108	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			166	return unless defined $extracted; # Broken source code
2847	1				2	$comma_pos += length $extracted;
2848	1				1	next;
2849						}
2850	92	100			94	if (substr($rest, 0, 1) eq ',') {
2851	20				25	$found_comma = 1;
2852	20				33	last;
2853						}
2854	72				58	$comma_pos++;
2855	72				78	$rest = substr($rest, 1);
2856						}
2857
2858	21	100			57	return unless $found_comma;
2859
2860	20				33	my $first_arg = substr($string, 0, $comma_pos);
2861	20				40	my $hash_str = substr($string, $comma_pos + 1);
2862
2863						# Trim whitespace
2864	20				51	$first_arg =~ s/^\s+\|\s+$//g;
2865	20				172	$hash_str =~ s/^\s+\|\s+$//g;
2866
2867	20				44	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	338			338	477	my ($self, $code) = @_;
2890
2891	338	100			674	return unless $code =~ /\bvalidated_hash\s*\(/;
2892
2893	9	50			21	my $doc = $self->_ppi($code) or return;
2894
2895						my $calls = $doc->find(sub {
2896	742	100		742	3427	$_[1]->isa('PPI::Token::Word') && ($_[1]->content eq 'validated_hash')
2897	9	50			34552	}) or return;
2898
2899	9				78	for my $call (@$calls) {
2900	9				31	my $list = $call->parent();
2901	9		67		266	while ($list && !$list->isa('PPI::Structure::List')) {
2902	36				275	$list = $list->parent;
2903						}
2904	9	50			28	if(!defined($list)) {
2905	9				34	my $next = $call->next_sibling();
2906	9				337	my ($arglist, $schema_text) = $self->_parse_pv_call($next);
2907
2908	9	50	33		40	if($schema_text && $schema_text !~ $UNSAFE_KEYWORD_RE) {
2909	9				94	my $compartment = Safe->new();
2910	9				4046	$compartment->permit_only(qw(:base_core :base_mem :base_orig));
2911
2912	9				53	my $schema_str = "my \$schema = { $schema_text }";
2913	9				27	$schema_str =~ s/ArrayRef\[(.+?)\]/arrayref, element_type => $1/g;
2914	9				22	my $schema = $compartment->reval($schema_str);
2915
2916	9 9	50			2914 34	if(scalar keys %{$schema}) {
2917	9 9				7 15	foreach my $arg(keys %{$schema}) {
2918	14				34	my $field = $schema->{$arg};
2919	14	50			26	if(my $isa = delete $field->{'isa'}) {
2920	14				16	$field->{'type'} = $isa;
2921						}
2922	14	100			21	if(exists($field->{'required'})) {
2923	11				31	my $required = delete $field->{'required'};
2924	11	100			18	$field->{'optional'} = $required ? 0 : 1;
2925						} else {
2926	3				4	$field->{'optional'} = 1;
2927						}
2928	14	100			26	if(ref($field->{'default'}) eq 'CODE') {
2929	2				29	delete $field->{'default'}; # TODO
2930						}
2931						}
2932
2933	9 9				11 14	foreach my $arg(keys %{$schema}) {
2934	14				14	my $field = $schema->{$arg};
2935	14	50			21	if(my $type = $field->{'type'}) {
2936	14	50 50			31	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				14	delete $field->{'callbacks'};
2943						}
2944
2945						return {
2946	9				44	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	7	my ($self, $block) = @_;
2988
2989	2	50	67		10	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	24	my ($self, $schema) = @_;
3022
3023	5				5	my %input;
3024
3025	5				10	for my $name (keys %$schema) {
3026	8				7	my $spec = $schema->{$name};
3027
3028						$input{$name} = {
3029						%$spec,
3030	8	100			28	optional => exists $spec->{optional} ? $spec->{optional} : 0,
3031						_source => 'validator',
3032						_type_confidence => 'high',
3033						};
3034						}
3035
3036						return {
3037	5				13	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	329			329	4179	my ($self, $code) = @_;
3064
3065	329	100			693	my $function = $self->_extract_function_name($code) or return;
3066
3067	328	100			865	my $doc = $self->{_document} or return;
3068	325	100			634	my $stmt = $self->_find_signature_statement($doc, $function) or return;
3069
3070	2	50			9	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				4	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	330			330	1374	my ($self, $code) = @_;
3094	330	100			1355	return $1 if $code =~ /^\s*sub\s+([a-zA-Z0-9_]+)/;
3095	3				8	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	325			325	4780	my ($self, $doc, $function) = @_;
3115
3116						my $statements = $doc->find(
3117						sub {
3118	237177	100		237177	1464589	$_[1]->isa('PPI::Statement') && $_[1]->content =~ /^\s*signature_for\b/
3119						}
3120	325	100			1013	) or return;
3121
3122	2				29	foreach my $stmt (@$statements) {
3123	2				4	my $content = $stmt->content;
3124	2	50			143	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	2790	my ($self, $stmt, $function) = @_;
3151
3152	3				7	my $content = $stmt->content;
3153
3154	3	100			193	if ($content =~ /^\ssignature_for\s+\Q$function\E\s=>\s(.+?);?\s$/s) {
3155	2				5	return $1;
3156						}
3157
3158	1				1	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	9576	my ($self, $function, $signature_expr) = @_;
3220
3221	10	100			41	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				4	return;
3227						}
3228
3229						# Remove comments
3230	8				20	$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		28	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				97	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				63	$payload =~ s/FUNCTION_NAME/$function/g;
3318	8				32	$payload =~ s/SIGNATURE_EXPR/$signature_expr/;
3319
3320						# Run in an isolated Perl process
3321	8				30	my ($wtr, $rdr, $err) = (undef, undef, gensym);
3322	8				94	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				28	$ENV{_ATG_RLIMIT_AS} = $MEMORY_LIMIT_BYTES;
3331
3332	8				49	my $pid = open3($wtr, $rdr, $err, $^X, '-T');
3333
3334	8				305	print $wtr $payload;
3335	8				26	close $wtr;
3336
3337	8 0			0	967 0	local $SIG{ALRM} = sub { croak 'Signature compile timeout' };
3338	8 8				7 14	eval { alarm($SIGNATURE_TIMEOUT_SECS) }; # no-op on Windows
3339
3340	8 8 8				43 13 26	my $stdout = do { local $/; <$rdr> };
3341	8 8 8				8 10 13	my $stderr = do { local $/; <$err> };
3342
3343	8 8				8 20	eval { alarm 0 };
3344
3345	8				26	waitpid($pid, 0);
3346
3347	8	100	67		18	if ($stderr && length $stderr) {
3348	1	50			3	carp "Error compiling signature:\n$stderr" if $self->{verbose};
3349	1				84	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		25	if (!defined($stdout) \|\| !length($stdout)) {
3356	4	50			12	carp 'Signature subprocess produced no output' if $self->{verbose};
3357	4				534	return;
3358						}
3359
3360	3 3				4 34	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				282	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	41	my ($self, $meta) = @_;
3394
3395	8				30	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				6	my $input;
3406	8				6	my $position = 0;
3407	8				8	my $confidence = 'high';
3408	8				9	my @notes = ('Type::Params detected');
3409
3410	8 8	50			8 17	foreach my $p (@{ $meta->{parameters} \|\| [] }) {
3411	8		100		16	my $type = $type_map{ $p->{type} } // 'string';
3412
3413	8	100			11	if (!exists $type_map{$p->{type}}) {
3414	1				1	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			25	optional => $p->{optional} ? 1 : 0,
3422						};
3423
3424	8				11	$position++;
3425						}
3426
3427	8				7	my $output;
3428
3429	8	100			11	if (my $ret = $meta->{returns}) {
3430	2		50		4	my $type = $type_map{ $ret->{type} } // 'string';
3431
3432	2	50			5	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				5	type => $type,
3439						"_$ret->{context}_context" => { type => $type },
3440						};
3441						}
3442
3443						return {
3444	8				34	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	340			340	472	my ($self, $pod) = @_;
3488
3489	340	100			507	return {} unless $pod;
3490
3491	140				131	my %params;
3492	140				165	my $position_counter = 0;
3493
3494						# Check for positional arguments in method signature
3495						# Pattern: =head2 method_name($arg1, $arg2, $arg3)
3496	140	100			514	if ($pod =~ /=head2\s+\w+\s*$([^)]+)$/s) {
3497	36				54	my $sig = $1;
3498						# Extract parameter names in order
3499	36				106	my @sig_params = $sig =~ /\$(\w+)/g;
3500
3501						# Skip $self or $class
3502	36	50	33		114	shift @sig_params if @sig_params && $sig_params[0] =~ /^(self\|class)$/i;
3503
3504						# Assign positions
3505	36				42	foreach my $param (@sig_params) {
3506	48		33		157	$params{$param}{position} //= $position_counter;
3507	48				105	$self->_log(" POD: $param has position $params{$param}{position}");
3508	48				52	$position_counter++;
3509						}
3510						}
3511
3512	140				321	$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	140				143	my $param_section;
3517	140	100 100			1867	if($pod =~ /(?:Parameters?\|Arguments?\|Inputs?):?\s\n((?:\s\$.*\n)+)/si) {
3518	30				51	$param_section = $1;
3519						} elsif ($pod =~ /^=head\d+\s+(?:Parameters?\|Arguments?\|Inputs?)\b.?\n(.?)(?=^=head\|\Z)/msi) {
3520	43				69	$param_section = $1;
3521						}
3522	140	100			271	if($param_section) {
3523	73				83	my $param_order = 0;
3524
3525	73				161	$self->_log(" POD: Scan for named parameters in '$param_section'");
3526						# Now parse each line that starts with $varname
3527	73				204	foreach my $line (split /\n/, $param_section) {
3528	407	50			461	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		708	if(($line =~ /^\s\$(\w+)\s-\s(\w+)(?:\s$([^)]+)$)?\s,?\s(.*)$/i) \|\|
3537						($line =~ /^\sC<\$(\w+)>\s-\s(\w+)(?:\s$([^)]+)$)?\s,?\s(.*)$/i)) {
3538	43				159	my ($name, $type, $constraint, $desc) = ($1, lc($2), $3, $4);
3539
3540						# Clean up
3541	43	100			121	$desc =~ s/^\s+\|\s+$//g if $desc;
3542
3543						# Skip common non-parameters
3544	43	100			89	next if $name =~ /^(self\|class\|return\|returns?)$/i;
3545
3546	42		100		87	$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			67	unless (exists $params{$name}{position}) {
3550	16				16	$params{$name}{position} = $param_order++;
3551	16				27	$self->_log(" POD: $name has position $params{$name}{position} (from Parameters order)");
3552						}
3553
3554						# Normalize type names
3555	42	50			58	$type = 'integer' if $type eq 'int';
3556	42	50	33		85	$type = 'number' if $type eq 'num' \|\| $type eq 'float';
3557	42	50			59	$type = 'boolean' if $type eq 'bool';
3558	42	50			53	$type = 'arrayref' if $type eq 'array';
3559	42	50			46	$type = 'hashref' if $type eq 'hash';
3560
3561	42				63	$params{$name}{type} = $type;
3562
3563						# Parse constraints
3564	42	100			52	if($constraint) {
3565	7				18	$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		103	my $full_text = ($constraint \|\| '') . ' ' . ($desc \|\| '');
3571	42	100 100			145	if ($full_text =~ /\boptional\b/i) {
3572	6				10	$params{$name}{optional} = 1;
3573	6				12	$self->_log(" POD: $name marked as optional");
3574						} elsif ($full_text =~ /required\|mandatory/i) {
3575	2				2	$params{$name}{optional} = 0;
3576	2				4	$self->_log(" POD: $name marked as required");
3577						}
3578
3579						# Detect semantic types:
3580	42	100			95	if ($desc =~ /\b(email\|url\|uri\|path\|filename)\b/i) {
3581						# TODO: ensure properties is set to 1 in $config
3582	2				70	carp('Manually set config->properties to 1 in ', $self->{'input_file'});
3583	2				336	$params{$name}{semantic} = lc($1);
3584						}
3585
3586						# Look for regex patterns
3587	42	100	100		85	if ($desc && $desc =~ m{matches?\s+(/[^/]+/\|qr/.+?/)}i) {
3588	1				3	$params{$name}{matches} = $1;
3589						}
3590
3591	42	100 100			126	$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	140				495	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				61	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			71	next if exists $params{$name};
3604
3605						# Clean up description - remove leading/trailing whitespace
3606	2	50			6	$desc =~ s/^\s+\|\s+$//g if $desc;
3607
3608						# Skip common words that aren't parameters
3609	2	100			6	next if $name =~ /^(self\|class\|return\|returns?)$/i;
3610
3611	1		50		4	$params{$name} \|\|= { _source => 'pod' };
3612
3613						# Normalize type names
3614	1	50			2	$type = 'integer' if $type eq 'int';
3615	1	50	33		4	$type = 'number' if $type eq 'num' \|\| $type eq 'float';
3616	1	50			1	$type = 'boolean' if $type eq 'bool';
3617	1	50			2	$type = 'arrayref' if $type eq 'array';
3618	1	50			2	$type = 'hashref' if $type eq 'hash';
3619
3620	1				3	$params{$name}{type} = $type;
3621
3622						# Parse constraints
3623	1	50			1	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			2	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			2	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	140				847	while ($pod =~ /=item\s+(?:\\s)?(?:C<)?\$(\w+)\b(?:>)?\s(?:-.)?\n?(.*?)(?==item\|\=back\|\=head)/sig) {
3648	23				38	my $name = $1;
3649	23				35	my $desc = $2;
3650
3651						# Never allow empty or undefined parameter names
3652	23	50	33		71	next unless defined $name && length $name;
3653
3654	23				74	$desc =~ s/^\s+\|\s+$//g;
3655
3656						# Skip common non-parameters
3657	23	50			56	next if $name =~ /^(self\|class\|return\|returns?)$/i;
3658
3659	23		100		104	$params{$name} \|\|= { _source => 'pod' };
3660
3661						# Explicit typed form only:
3662						# $param - type (constraints)
3663	23	100			82	if ($desc =~ /^\s(string\|integer\|int\|number\|num\|float\|boolean\|bool\|array\|arrayref\|hash\|hashref\|any)\b(?:\s$([^)]+)$)?/i) {
3664	7				13	my $type = lc($1);
3665	7				12	my $constraint = $2;
3666
3667						# Normalize type names
3668	7	50			11	$type = 'integer' if $type eq 'int';
3669	7	50	33		24	$type = 'number' if $type eq 'num' \|\| $type eq 'float';
3670	7	50			7	$type = 'boolean' if $type eq 'bool';
3671	7	50			9	$type = 'arrayref' if $type eq 'array';
3672	7	50			11	$type = 'hashref' if $type eq 'hash';
3673
3674	7				12	$params{$name}{type} = $type;
3675
3676	7	100			10	if ($constraint) {
3677	3				10	$self->_parse_constraints($params{$name}, $constraint);
3678						}
3679
3680	7				18	$self->_log(" POD: Explicit type '$type' for $name");
3681						} else {
3682						# Heuristic inference from description text
3683	16	50 50 50 50			85	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			88	if ($desc =~ /\boptional\b/i) {
3697	1				1	$params{$name}{optional} = 1;
3698						} elsif ($desc =~ /required\|mandatory/i) {
3699	7				12	$params{$name}{optional} = 0;
3700						}
3701
3702						# Look for regex patterns
3703	23	50			44	if ($desc =~ m{matches?\s+(/[^/]+/\|qr/.+?/)}i) {
3704	0				0	$params{$name}{matches} = $1;
3705						}
3706
3707	23				48	$self->_log(" POD: Found parameter '$name' from =item list");
3708						}
3709
3710						# Extract default values from POD
3711	140				403	my $pod_defaults = $self->_extract_defaults_from_pod($pod);
3712	140				300	foreach my $param (keys %$pod_defaults) {
3713	10	50			10	if (exists $params{$param}) {
3714	10				9	$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			23	defined($pod_defaults->{$param}) ? $pod_defaults->{$param} : 'undef'
3719						));
3720						}
3721						}
3722
3723						# Default undocumented optionality: documented params are REQUIRED unless stated otherwise
3724	140				256	for my $name (keys %params) {
3725	86	50			148	next if $name =~ /^(self\|class)$/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	140	100			561	if ($pod =~ /=head[34]\s+Input\b(.*?)(?==head\|\z)/si) {
3740	23				27	my $block = $1;
3741	23				49	$block =~ s/\A\s+//;
3742
3743	23	100 100			70	if ($block =~ /\A\[/) {
3744						# Positional format: each {â€¦} maps to the param at that array index.
3745	7				7	my $idx = 0;
3746	7				20	while ($block =~ /\{([^}]*)\}/g) {
3747	9				10	my $spec = $1;
3748	9 3		50		14 7	my ($name) = grep { ($params{$_}{position} // -1) == $idx }
3749						keys %params;
3750	9	100			17	if (defined $name) {
3751	3				4	$params{$name}{_from_input_spec} = 1;
3752	3	50			7	if (my $t = $self->_map_formal_input_type($spec)) {
3753	3				3	$params{$name}{type} = $t;
3754	3				5	$self->_log(" POD: $name type '$t' from =head Input (positional $idx)");
3755						}
3756	3	50			5	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				34	my ($name, $spec) = ($1, $2);
3766	22	100			53	next if $name =~ /^(self\|class)$/i;
3767	13		100		59	$params{$name} //= { _source => 'pod' };
3768	13				21	$params{$name}{_from_input_spec} = 1;
3769	13	50			33	if (my $t = $self->_map_formal_input_type($spec)) {
3770	13				19	$params{$name}{type} = $t;
3771	13				20	$self->_log(" POD: $name type '$t' from =head Input (named)");
3772						}
3773	13	100			31	if ($spec =~ /\boptional\s=>\s(0\|1)/i) {
3774	2				4	$params{$name}{optional} = $1 + 0;
3775						}
3776	13	50			24	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			31	if ($spec =~ /\bmin\s=>\s(\d+)/i) {
3785	4				9	$params{$name}{min} = $1 + 0;
3786						}
3787	13	100			26	if ($spec =~ /\bmax\s=>\s(\d+)/i) {
3788	3				5	$params{$name}{max} = $1 + 0;
3789						}
3790	13	50			35	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				31	delete $params{$_}{position} for keys %params;
3798						}
3799						}
3800
3801	140				219	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	1185	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			66	return undef unless $spec =~ /\btype\s=>\s(?:['"]([^'"]+)['"]\|([A-Z_]+))/i;
3826	20	100			41	my $raw = lc(defined($1) ? $1 : $2);
3827	20				33	$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				35	for my $t (split /\\|/, $raw) {
3852	20	100			64	return $map{$t} if exists $map{$t};
3853						}
3854	1				6	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	330			330	2518	my ($self, $pod, $code, $method_name) = @_;
3885
3886	330				299	my %output;
3887
3888	330				948	$self->_analyze_output_from_pod(\%output, $pod);
3889	330				898	$self->_analyze_output_from_code(\%output, $code, $method_name);
3890	330				859	$self->_enhance_boolean_detection(\%output, $pod, $code, $method_name);
3891	330				868	$self->_detect_list_context(\%output, $code);
3892	330				1324	$self->_detect_void_context(\%output, $code, $method_name);
3893	330				718	$self->_detect_chaining_pattern(\%output, $code);
3894	330				892	$self->_detect_error_conventions(\%output, $code);
3895
3896	330	100			943	$self->_validate_output(\%output) if keys %output;
3897
3898						# Don't return empty output
3899	330	100			1195	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	333			333	456	my ($self, $output, $pod) = @_;
3927	333 3663				508 4251	my %VALID_OUTPUT_TYPES = map { $_ => 1 }
3928						qw(string integer number float boolean arrayref hashref object coderef void undef);
3929
3930	333	100			823	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	135	100			499	if($pod =~ /=head4\s+Output\b(.*?)(?==head\|\z)/si) {
3937	16				27	my $block = $1;
3938	16				38	$block =~ s/^\s+//;
3939	16	100 50 100			82	if($block =~ /^\(/) {
3940	2				4	$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			44	if($block =~ /type\s=>\s['"]?(\w[\w:]?)['"]?\s[,}]/i) {
3949	10				20	my $type = lc($1);
3950	10	50			18	$type = 'hashref' if $type eq 'hash';
3951	10	50			18	$type = 'arrayref' if $type eq 'array';
3952	10	100 50			28	if($VALID_OUTPUT_TYPES{$type}) {
3953	3				7	$output->{type} = $type;
3954	3				8	$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	135	100			307	if ($pod =~ /Returns?:\s+([^\n]+(?:\n[^\n]+){0,2})/si) {
3969	8				11	my $returns_desc = $1;
3970	8				24	$returns_desc =~ s/^\s+\|\s+$//g;
3971
3972	8				20	$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		160	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				2	$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				4	$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			29	if ($returns_desc =~ /\b1\s+(?:on\s+success\|if\s+successful)\b/i) {
3995	1				2	$output->{value} = 1;
3996	1	50	33		3	if(defined($output->{'type'}) && ($output->{type} eq 'scalar')) {
3997	0				0	$output->{type} = 'boolean';
3998						} else {
3999	1		50		3	$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			19	if ($returns_desc =~ /\b(true\|false)\b/i) {
4009	1		50		2	$output->{type} \|\|= 'boolean';
4010						}
4011	8	50			16	if ($returns_desc =~ /\bundef\b/i) {
4012	0				0	$output->{optional} = 1;
4013						}
4014						}
4015
4016						# Pattern 2: Inline "returns X"
4017	135	100	100		654	if((!$output->{type}) && ($pod =~ /returns?\s+(?:an?\s+)?(\w+)/i)) {
4018	45				90	my $type = lc($1);
4019
4020	45	100			116	$type = 'boolean' if $type =~ /^(true\|false\|bool)$/;
4021						# Skip if it's just a number (like "returns 1")
4022	45	50			85	$type = 'integer' if $type eq 'int';
4023	45	50			113	$type = 'number' if $type =~ /^(num\|float)$/;
4024	45	50			68	$type = 'arrayref' if $type eq 'array';
4025	45	50			55	$type = 'hashref' if $type eq 'hash';
4026
4027	45	100			89	if($type =~ /^\d+$/) {
4028	2	50	33		7	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				3	$type = 'integer';
4036						}
4037						} else {
4038	0				0	$type = 'integer';
4039						}
4040						}
4041
4042	45	50	33		74	$type = 'arrayref' if !$type && $pod =~ /returns?\s+.+\slist\b/i;
4043						# $output->{type} = $type if $type && $type !~ /^\d+$/;
4044	45	100			77	if ($VALID_OUTPUT_TYPES{$type}) {
4045	15				26	$output->{type} = $type;
4046	15				38	$self->_log(" OUTPUT: Inferred type from POD: $type");
4047						} else {
4048	30				68	$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	146			146	2518	my ($self, $pod) = @_;
4081
4082	146	100			217	return {} unless $pod;
4083
4084	145				160	my %defaults;
4085
4086						# Pattern 1: Default: 'value' or Defaults to: 'value'
4087	145				435	while ($pod =~ /(?:Default(?:s? to)?\|default(?:s? to)?)[:]\s*([^\n\r]+)/gi) {
4088	19				21	my $default_text = $1;
4089	19				15	my $match_pos = pos($pod);
4090	19				51	$default_text =~ s/^\s+\|\s+$//g;
4091
4092						# Look backwards in the POD to find the parameter name
4093	19				24	my $context = substr($pod, 0, $match_pos);
4094	19				45	my @param_matches = ($context =~ /\$(\w+)/g);
4095	19	50			22	my $param = $param_matches[-1] if @param_matches; # Last parameter before default
4096
4097	19	50			19	if ($param) {
4098						# Always clean the default value - let _clean_default_value handle everything
4099	19	50			25	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				29	$defaults{$param} = $self->_clean_default_value($default_text, 0); # NOT from code
4106						}
4107						}
4108						}
4109
4110						# Pattern 2: Optional, default 'value'
4111	145				374	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				12	$default_text =~ s/^\s+\|\s+$//g;
4115
4116						# Look backwards for parameter name
4117	6				8	my $context = substr($pod, 0, $match_pos);
4118	6				15	my @param_matches = ($context =~ /\$(\w+)/g);
4119	6	50			8	if (@param_matches) {
4120	6				6	my $param = $param_matches[-1]; # Last parameter before the default
4121	6				9	$defaults{$param} = $self->_clean_default_value($default_text, 0);
4122						}
4123						}
4124
4125						# Pattern 3: In parameter descriptions: $param - type, default 'value'
4126	145				513	while ($pod =~ /\$(\w+)\s-\s\w+(?:$[^)]*$)?[,\s]+default\s+['"]?([^'",\n]+)['"]?/gi) {
4127	1				2	my ($param, $value) = ($1, $2);
4128	1				2	$defaults{$param} = $self->_clean_default_value($value, 0);
4129						}
4130
4131	145				212	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	332			332	527	my ($self, $output, $code, $method_name) = @_;
4156
4157	332	50			465	if ($code) {
4158						# Early boolean detection - check for consistent 1/0 returns
4159	332				1253	my @all_returns = $code =~ /return\s+([^;]+);/g;
4160	332	100			488	if (@all_returns) {
4161	313				308	my $boolean_count = 0;
4162	313				278	my $total_count = scalar(@all_returns);
4163
4164	313				441	foreach my $ret (@all_returns) {
4165	350				858	$ret =~ s/^\s+\|\s+$//g;
4166						# Match 0 or 1, even with conditions
4167	350	100			706	$boolean_count++ if ($ret =~ /^(?:0\|1)(?:\s\|$)/);
4168						}
4169
4170						# If most returns are 0 or 1, strongly suggest boolean
4171	313	100	100		639	if ($boolean_count >= 2 && $boolean_count >= $total_count * 0.8) {
4172	5	50			48	unless ($output->{type}) {
4173	5				10	$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	332				288	my @return_statements;
4180
4181	332	100 100 100 50 100 100	100		2870	if ($code =~ /return\s+bless\s\{[^}]\}\s,\s['"]?(\w+)['"]?/s) {
4182						# Detect blessed refs
4183	2				4	$output->{type} = 'object';
4184	2	50			4	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				3	$output->{isa} = $1;
4192						}
4193	2				5	$self->_log(" OUTPUT: Bless found, inferring type from code is $output->{isa}");
4194						} elsif ($code =~ /return\s+bless/s) {
4195	22				45	$output->{type} = 'object';
4196	22	100			41	if($method_name eq 'new') {
4197	21				43	$output->{isa} = $self->_extract_package_name();
4198	21				383	$self->_log(" OUTPUT: Bless found, inferring type from code is $output->{isa}");
4199						} else {
4200	1				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				1	$output->{type} = 'array'; # Not arrayref - actual array
4205	1				2	$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				1	my $content = $1;
4218	1	50			4	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				13	$output->{type} = 'object';
4224	7	50			16	if ($self->{_document}) {
4225	7				17	my $pkg = $self->{_document}->find_first('PPI::Statement::Package');
4226	7	50			746	$output->{isa} = $pkg ? $pkg->namespace : 'UNKNOWN';
4227	7		50		167	$self->_log(' OUTPUT: Object chained into __PACKAGE__: ' . ($output->{isa} \|\| 'UNKNOWN'));
4228	7		33		13	$self->{_package_name} //= $output->{isa};
4229						}
4230						}
4231
4232						# Find all return statements
4233	332				1046	while ($code =~ /return\s+([^;]+);/g) {
4234	350				482	my $return_expr = $1;
4235	350				513	push @return_statements, $return_expr;
4236						}
4237
4238	332	100			415	if (@return_statements) {
4239	313				740	$self->_log(' OUTPUT: Found ' . scalar(@return_statements) . ' return statement(s)');
4240
4241						# Analyze return patterns
4242	313				314	my %return_types;
4243
4244	313	100			496	if($output->{'type'}) {
4245	56				111	$return_types{$output->{'type'}} += 3; # Add weighting to what's already been found
4246						}
4247	313				306	my $min;
4248	313				378	foreach my $ret (@return_statements) {
4249	350				724	$ret =~ s/^\s+\|\s+$//g;
4250
4251						# Literal values
4252	350	100 100 100 50 100 50 100 100 50 50 50 50 50 50 100 100	100 100		3420	if ($ret eq '1' \|\| $ret eq '0') {
4253	33				58	$return_types{boolean}++;
4254						} elsif ($ret =~ /^['"]/) {
4255	22				40	$return_types{string}++;
4256						} elsif ($ret =~ /^-?\d+$/) {
4257	105				155	$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				2	$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				96	$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	9	50			28	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	9				17	$return_types{scalar}++;
4302						}
4303						}
4304						# Variables/expressions
4305						elsif ($ret =~ /\$\w+/) {
4306	115	50 50 100 50 50			573	if ($ret =~ /\\\@/) {
4307	0				0	$return_types{arrayref}++;
4308						} elsif ($ret =~ /\\\%/) {
4309	0				0	$return_types{hashref}++;
4310						} elsif ($ret =~ /bless/) {
4311	2				4	$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				214	$return_types{scalar}++;
4318						}
4319						}
4320						}
4321
4322						# Determine most common return type
4323	313	100			485	if (keys %return_types) {
4324	309 55				633 146	my ($most_common) = sort { $return_types{$b} <=> $return_types{$a} } keys %return_types;
4325						# Prefer integer over scalar if numeric returns dominate
4326	309	100	67		702	if ($return_types{integer} && (!$return_types{string})) {
4327	104	100	67		188	if (!$output->{type} \|\| $output->{type} eq 'scalar') {
4328	102				154	$output->{type} = 'integer';
4329	102				154	$self->_log(" OUTPUT: Numeric returns dominate, forcing integer");
4330	102		50		264	$output->{_type_confidence} \|\|= 'low';
4331	102	50			117	if(defined($min)) {
4332	0				0	$output->{min} = $min;
4333						}
4334						}
4335						}
4336	309	100			509	unless ($output->{type}) {
4337	151				265	$output->{type} = $most_common;
4338
4339						# Assign confidence for inferred numeric expressions
4340	151	100			256	if ($most_common eq 'number') {
4341	34		50		120	$output->{_type_confidence} \|\|= 'medium';
4342	34	50			56	if(defined($min)) {
4343	0				0	$output->{min} = $min;
4344						}
4345						}
4346
4347	151				330	$self->_log(" OUTPUT: Inferred type from code: $most_common");
4348						}
4349						}
4350
4351						# Check for consistent single value returns
4352	313	100	100		1130	if (@return_statements == 1 && $return_statements[0] eq '1') {
4353	24				37	$output->{value} = 1;
4354	24	50	33		84	$output->{type} = 'boolean' if !$output->{type} \|\| $output->{type} eq 'scalar';
4355	24	50			74	$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	19				29	$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	331			331	555	my ($self, $output, $pod, $code, $method_name) = @_;
4393
4394	331				313	my $boolean_score = 0; # Track evidence for boolean return
4395
4396	331	100	67		969	return unless !$output->{type} \|\| $output->{type} eq 'unknown';
4397
4398						# Look for stronger boolean indicators
4399	25	100	67		49	if ($pod && !$output->{type}) {
4400						# Common boolean return patterns in POD
4401	3	50			8	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	3	50			19	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	25	50			47	if ($code) {
4418						# Count boolean return idioms
4419	25				56	my $true_returns = () = $code =~ /return\s+1\s*;/g;
4420	25				42	my $false_returns = () = $code =~ /return\s+0\s*;/g;
4421
4422	25	50 100			66	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				4	$self->_log(' OUTPUT: Single 1/0 return (+10)');
4428						}
4429
4430						# Ternary operators that return booleans
4431	25	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	25	50			64	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	25	50			30	if ($method_name) {
4446	25	100			54	if ($method_name =~ /^(?:is_\|has_\|can_\|should_\|contains_\|exists_\|check_\|verify_\|validate_)/) {
4447	2				3	$boolean_score += 25;
4448	2				4	$self->_log(" OUTPUT: Method name '$method_name' suggests boolean return (+25)");
4449						}
4450	25	50			50	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	25	100			68	if($boolean_score >= $BOOLEAN_SCORE_THRESHOLD) {
4459	2	50	20		8	if (!$output->{type} \|\| $output->{type} eq 'scalar' \|\| $output->{type} eq 'array' \|\| $output->{type} eq 'undef') {
4460	2		50		5	my $old_type = $output->{type} \|\| 'none';
4461	2				3	$output->{type} = 'boolean';
4462	2				5	$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	331			331	472	my ($self, $output, $code) = @_;
4489	331	50			407	return unless $code;
4490
4491						# Check for wantarray usage
4492	331	100			738	if ($code =~ /wantarray/) {
4493	5				8	$output->{_context_aware} = 1;
4494	5				9	$self->_log(' OUTPUT: Method uses wantarray - context sensitive');
4495
4496						# Debug: show what we're matching against
4497	5	100			14	if ($code =~ /(wantarray[^;]+;)/s) {
4498	4				12	$self->_log(" DEBUG wantarray line: $1");
4499						}
4500
4501	5	100 100 50			29	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				8	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				8	$self->_log(" DEBUG list (no parens): [$list_return], scalar: [$scalar_return]");
4517
4518	3				8	$output->{_list_context} = $self->_infer_type_from_expression($list_return);
4519	3				4	$output->{_scalar_context} = $self->_infer_type_from_expression($scalar_return);
4520	3				6	$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				3	$output->{_list_context} = { type => 'array' };
4524	1				2	$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	331	100			796	if ($code =~ /return\s$\s([^)]+)\s$\s;/) {
4531	4				7	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				445	require Text::Balanced;
4536	4				4089	my $comma_count = 0;
4537	4				6	my $rest = $content;
4538	4				7	while (length $rest) {
4539	44	100			48	if (substr($rest, 0, 1) =~ /[(\[{]/) {
4540	5				10	my $extracted = Text::Balanced::extract_bracketed($rest, '(){}[]');
4541	5	50			401	last unless defined $extracted; # Unbalanced brackets
4542	5				7	next;
4543						}
4544	39	100			35	$comma_count++ if substr($rest, 0, 1) eq ',';
4545	39				65	$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		9	unless ($output->{type} && $output->{type} eq 'boolean') {
4551	3				4	$output->{type} = 'array';
4552	3				5	$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	331			331	513	my ($self, $output, $code, $method_name) = @_;
4583	331	50			393	return unless $code;
4584
4585	331				606	$self->_log(" DEBUG _detect_void_context called for $method_name");
4586
4587						# Methods that typically don't return meaningful values
4588	331				1914	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	331				540	foreach my $type (keys %$void_patterns) {
4597	1310	100			2518	if ($method_name =~ $void_patterns->{$type}) {
4598	14				29	$output->{_void_context_hint} = $type;
4599	14				28	$self->_log(" OUTPUT: Method name suggests $type (typically void context)");
4600	14				18	last;
4601						}
4602						}
4603
4604						# Analyze return statements
4605	331				918	my @returns = $code =~ /return\s([^;]);/g;
4606
4607	331				666	$self->_log(' DEBUG Found ' . scalar(@returns) . ' return statements');
4608
4609						# Count different return patterns
4610	331				349	my $no_value_returns = 0;
4611	331				295	my $true_returns = 0;
4612	331				320	my $self_returns = 0;
4613
4614	331				411	foreach my $ret (@returns) {
4615	353				703	$ret =~ s/^\s+\|\s+$//g;
4616	353				578	$self->_log(" DEBUG return value: [$ret]");
4617	353	100			439	$no_value_returns++ if $ret eq '';
4618	353	100			552	$no_value_returns++ if($ret =~ /^(if\|unless)\s/);
4619	353	100			403	$true_returns++ if $ret eq '1';
4620	353	100			384	$self_returns++ if $ret eq '$self';
4621	353	100			568	if ($ret =~ /\?\s1\s:\s*0\b/) {
4622						# Strong boolean signal: ternary returning 1/0
4623	12				12	$true_returns++;
4624						# $self->_log(" OUTPUT: Ternary 1:0 return detected, treating as boolean (+40)");
4625	12				16	$self->_log(' OUTPUT: Ternary 1:0 return detected, treating as boolean');
4626						}
4627						}
4628
4629	331				322	my $total_returns = scalar(@returns);
4630
4631	331				683	$self->_log(" DEBUG no_value=$no_value_returns, true=$true_returns, self=$self_returns, total=$total_returns");
4632
4633						# Void context indicators
4634	331	100 100	100 75		1509	if ($no_value_returns > 0 && $no_value_returns == $total_returns) {
4635	6				9	$output->{_void_context} = 1;
4636	6				9	$output->{type} = 'void'; # This should override any previous type
4637	6				7	$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				55	$output->{_success_indicator} = 1;
4641						# Don't override type if already set to boolean
4642	37	100	100		116	unless ($output->{type} && $output->{type} eq 'boolean') {
4643	5				7	$output->{type} = 'boolean';
4644						}
4645	37				54	$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	330			330	470	my ($self, $output, $code) = @_;
4672	330	50			374	return unless $code;
4673
4674						# Count returns of $self
4675	330				316	my $self_returns = 0;
4676	330				310	my $total_returns = 0;
4677
4678	330				912	while ($code =~ /return\s+([^;]+);/g) {
4679	347				389	my $ret = $1;
4680	347				710	$ret =~ s/^\s+\|\s+$//g;
4681	347				273	$total_returns++;
4682	347	100			572	$self_returns++ if $ret eq '$self';
4683						}
4684
4685						# If most/all returns are $self, it's a chaining method
4686	330	100	67		657	if ($self_returns > 0 && $total_returns > 0) {
4687	9				13	my $ratio = $self_returns / $total_returns;
4688
4689	9	100			18	if ($ratio >= 0.8) {
4690	7				8	$output->{type} = 'object';
4691	7				14	$output->{_returns_self} = 1;
4692
4693						# Get the class name
4694	7	100			17	if ($self->{_document}) {
4695	6				14	my $pkg = $self->{_document}->find_first('PPI::Statement::Package');
4696	6	50			393	$output->{isa} = $pkg ? $pkg->namespace : 'UNKNOWN';
4697	6		33		72	$self->{_package_name} //= $output->{isa};
4698						}
4699
4700	7				34	$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	331			331	487	my ($self, $output, $code) = @_;
4729
4730	331	50			382	return unless $code;
4731
4732	331				507	$self->_log(' DEBUG _detect_error_conventions called');
4733
4734	331				253	my %error_patterns;
4735
4736						# Pattern 1: return undef if/unless condition
4737	331				710	while ($code =~ /return\s+undef\s+(?:if\|unless)\s+([^;]+);/g) {
4738	7 7				7 14	push @{$error_patterns{undef_on_error}}, $1;
4739	7				9	$self->_log(" DEBUG Found 'return undef' pattern");
4740						}
4741
4742						# Pattern 2: return if/unless (implicit undef)
4743	331				864	while ($code =~ /return\s+(?:if\|unless)\s+([^;]+);/g) {
4744	7 7				6 16	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	331	100			743	if ($code =~ /return\s$\s$\s*(?:if\|unless\|;)/) {
4750	3				7	$error_patterns{empty_list} = 1;
4751	3				6	$self->_log(" DEBUG Found empty list return");
4752						}
4753
4754						# Pattern 4: return 0/1 pattern (indicates boolean with error handling)
4755	331				331	my $zero_returns = 0;
4756	331				321	my $one_returns = 0;
4757						# Match "return 0" or "return 1" followed by anything (condition or semicolon)
4758	331				936	while ($code =~ /return\s+(0\|1)\s*(?:;\|if\|unless)/g) {
4759	41	100			77	if ($1 eq '0') {
4760	9				15	$zero_returns++;
4761						} else {
4762	32				46	$one_returns++;
4763						}
4764						}
4765
4766	331	100	100		583	if ($zero_returns > 0 && $one_returns > 0) {
4767	5				7	$error_patterns{zero_on_error} = 1;
4768	5				9	$self->_log(" DEBUG Found 0/1 return pattern ($zero_returns zeros, $one_returns ones)");
4769						}
4770
4771						# Pattern 5: Exception handling with eval
4772	331	100			623	if ($code =~ /eval\s*\{/) {
4773						# Check if there's error handling after eval
4774	3	50			17	if ($code =~ /eval\s\{.?\}[^}](?:if\s\(\s*\$\@\|catch\|return\s+undef)/s) {
4775	3				7	$error_patterns{exception_handling} = 1;
4776	3				4	$self->_log(' DEBUG Found exception handling with eval');
4777						}
4778						}
4779
4780						# Detect success/failure return pattern
4781	331				767	my @all_returns = $code =~ /return\s+([^;]+);/g;
4782	331 351				422 629	my $has_undef = grep { /^\sundef\s(?:if\|unless\|$)/ } @all_returns;
4783	331 351		67		339 1044	my $has_value = grep { !/^\sundef\s$/ && !/^\s*$/ } @all_returns;
4784
4785	331	50	50		550	if ($has_undef && $has_value && scalar(@all_returns) >= 2) {
4786	6				12	$output->{_success_failure_pattern} = 1;
4787	6				11	$self->_log(" OUTPUT: Uses success/failure return pattern");
4788						}
4789
4790						# Store error conventions in output
4791	331	100			419	if(scalar(keys %error_patterns)) {
4792	20				34	$output->{_error_handling} = \%error_patterns;
4793
4794						# Determine primary error convention
4795	20	100 100 100 100			64	if ($error_patterns{undef_on_error}) {
4796	5				8	$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				13	$self->_log(" OUTPUT: Returns implicit undef on error");
4801						} elsif ($error_patterns{empty_list}) {
4802	3				5	$output->{_error_return} = 'empty_list';
4803	3				5	$self->_log(" OUTPUT: Returns empty list on error");
4804						} elsif ($error_patterns{zero_on_error}) {
4805	5				10	$output->{_error_return} = 'false';
4806	5				7	$self->_log(" OUTPUT: Returns 0/false on error");
4807						}
4808
4809	20	100			48	if ($error_patterns{exception_handling}) {
4810	3				5	$self->_log(" OUTPUT: Has exception handling");
4811						}
4812						} else {
4813	311				453	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	702	my ($self, $expr) = @_;
4840
4841	37	100			54	return { type => 'scalar' } unless defined $expr;
4842
4843	35				90	$expr =~ s/^\s+\|\s+$//g;
4844
4845						# Check for multiple comma-separated values (indicates array/list)
4846	35	100			64	if ($expr =~ /,/) {
4847	5				941	require Text::Balanced;
4848	5				8282	my $comma_count = 0;
4849	5				6	my $rest = $expr;
4850	5				13	while (length $rest) {
4851	42	100			45	if (substr($rest, 0, 1) =~ /[(\[{]/) {
4852	5				10	my $extracted = Text::Balanced::extract_bracketed($rest, '(){}[]');
4853	5	50			428	last unless defined $extracted; # Unbalanced brackets
4854	5				8	next;
4855						}
4856	37	100			38	$comma_count++ if substr($rest, 0, 1) eq ',';
4857	37				36	$rest = substr($rest, 1);
4858						}
4859
4860	5	100			13	if ($comma_count > 0) {
4861	3				12	return { type => 'array' };
4862						}
4863						}
4864
4865						# Check for @ prefix (array)
4866	32	100	75		119	if ($expr =~ /^\@\w+/ \|\| $expr =~ /^qw\(/ \|\| $expr =~ /^\@\{/) {
4867	6				19	return { type => 'array' };
4868						}
4869
4870						# Check for scalar() function - returns count
4871	26	100			52	if ($expr =~ /scalar\s*\(/) {
4872	4				12	return { type => 'integer', min => 0 };
4873						}
4874
4875						# Check for array reference
4876	22	100	100		54	if ($expr =~ /^\[/ \|\| $expr =~ /^\\\@/) {
4877	4				16	return { type => 'arrayref' };
4878						}
4879
4880						# Check for hash reference
4881	18	100	100		46	if ($expr =~ /^\{/ \|\| $expr =~ /^\\\%/) {
4882	3				12	return { type => 'hashref' };
4883						}
4884
4885						# Check for hash
4886	15	50	33		37	if ($expr =~ /^\%\w+/ \|\| $expr =~ /^\%\{/) {
4887	0				0	return { type => 'hash' };
4888						}
4889
4890						# Check for strings
4891	15	100	67		45	if ($expr =~ /^['"]/ \|\| $expr =~ /['"]$/) {
4892	2				9	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			26	if($expr =~ /^[01]$/) {
4898	4				15	return { type => 'boolean' };
4899						}
4900
4901						# Check for integers
4902	9	100			27	if($expr =~ /^-?\d+$/) {
4903	4				14	return { type => 'integer' };
4904						}
4905
4906	5	100			13	if ($expr =~ /^-?\d+\.\d+$/) {
4907	2				7	return { type => 'number' };
4908						}
4909
4910						# Check for objects
4911	3	50			15	if ($expr =~ /bless/) {
4912	0				0	return { type => 'object' };
4913						}
4914
4915	3	100			12	if($expr =~ /\blength\s*\(/) {
4916	2				8	return { type => 'integer', min => 0 };
4917						}
4918
4919						# Default to scalar
4920	1				3	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	19	my ($self, $output, $pod) = @_;
4943	5	100			8	return unless $pod;
4944
4945						# Look for explicit chaining documentation
4946	4	100	80		29	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				8	$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	322			322	2435	my ($self, $output) = @_;
4976
4977						# Warn about suspicious combinations
4978	322	100	100		1017	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	322	50	50		654	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	322 2898				507 2855	my %valid_types = map { $_ => 1 } qw(string integer number boolean array arrayref hashref object void);
4985	322	100			597	if(exists $output->{type}) {
4986	317	100			1180	if(!$valid_types{$output->{type}}) {
4987	73				224	$self->_log(" WARNING Output value type is unknown: '$output->{type}', setting to string");
4988	73				139	$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	2675	my ($self, $param, $constraint) = @_;
5016
5017						# Range: "3-50" or "1-100 chars"
5018	25	100 100 100 100 100 100 100			168	if ($constraint =~ /(\d+)\s-\s(\d+)/) {
5019	8				15	$param->{min} = $1;
5020	8				14	$param->{max} = $2;
5021						}
5022						elsif ($constraint =~ /(\d+)\s\.\.\s(\d+)/) {
5023						# Range: 0..19
5024	2				4	$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				7	$param->{min} = $1;
5030						}
5031						# Maximum: "max 50" or "up to 100"
5032						elsif ($constraint =~ /(?:max\|maximum\|up to)\s*(\d+)/i) {
5033	3				5	$param->{max} = $1;
5034						}
5035						# Positive
5036						elsif ($constraint =~ /positive/i) {
5037	2	100	67		7	$param->{min} = 1 if $param->{type} && $param->{type} eq 'integer';
5038	2	100	67		8	$param->{min} = 0.01 if $param->{type} && $param->{type} eq 'number';
5039						}
5040						# Non-negative
5041						elsif ($constraint =~ /non-negative/i) {
5042	2				3	$param->{min} = 0;
5043						} elsif($constraint =~ /^(\S+)\s+(.+)$/) {
5044	2				4	my ($op, $val) = ($1, $2);
5045	2	50			6	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			59	if(defined($param->{max})) {
5059	13				25	$self->_log(" Set max to $param->{max}");
5060						}
5061	25	100			38	if(defined($param->{min})) {
5062	18				29	$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	331			331	2111	my ($self, $code, $method) = @_;
5097
5098	331				304	my %params;
5099
5100						# Safety check - limit parameter analysis to prevent runaway processing
5101	331				336	my $param_count = 0;
5102
5103						# Extract parameter names from various signature styles
5104	331				735	$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	331	100			690	if($code =~ /Params::Get/) {
5110	2				2	my $pos = scalar keys %params;
5111	2				7	while($code =~ /get_params\s\(\s['"](\w+)['"]/g) {
5112	2				2	my $name = $1;
5113	2	50			3	next if $name =~ /^(self\|class)$/i;
5114	2		50		13	$params{$name} //= { _source => 'code', position => $pos++ };
5115	2				3	$self->_log(" CODE: Found Params::Get parameter '$name'");
5116						}
5117						}
5118
5119	331				908	$self->_extract_defaults_from_code(\%params, $code, $method);
5120
5121						# Infer types from defaults
5122	331				479	foreach my $param (keys %params) {
5123	226	100	100		464	if ($params{$param}{_default} && !$params{$param}{type}) {
5124	20				19	my $default = $params{$param}{_default};
5125	20	100 100			41	if (ref($default) eq 'HASH') {
5126	2				4	$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				2	$params{$param}{type} = 'arrayref';
5130	1				3	$self->_log(" CODE: $param type inferred as arrayref from default");
5131						}
5132						}
5133						}
5134
5135	331	50 50			1018	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	331				455	foreach my $param (keys %params) {
5151	226	50			466	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	226				295	my $p = \$params{$param};
5157
5158	226				570	$self->_analyze_parameter_type($p, $param, $code);
5159	226				681	$self->_analyze_parameter_constraints($p, $param, $code);
5160	226				590	$self->_analyze_parameter_validation($p, $param, $code);
5161	226				559	$self->_analyze_advanced_types($p, $param, $code);
5162
5163						# Defined checks
5164	226	100			2985	if ($code =~ /defined\s$\s\$$param\s*$/) {
5165	1				1	$$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	226	100 100 50			13340	if ($code =~ /\s\$$param\s(?:\/\/\|\\|\\|)=/) {
5171						# e.g. $var //= 5; or $var \|\|= 5;
5172	8				14	$$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				79	$$p->{optional} = 0;
5178	42		50		93	$$p->{type} //= 'number';
5179	42				89	$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	226	50			6725	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	226	50			7648	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	226	50			2988	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	226	50			2936	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	226				524	$self->_extract_error_constraints($p, $param, $code);
5217						}
5218
5219	331				473	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	230			230	383	my ($self, $p_ref, $param, $code) = @_;
5245	230				236	my $p = $$p_ref;
5246
5247						# Type inference from ref() checks
5248	230	100 100 100			20543	if ($code =~ /ref\s$\s\$$param\s$\seq\s*['"](ARRAY\|HASH\|SCALAR)['"]/gi) {
5249	6				12	my $reftype = lc($1);
5250	6	50 100			18	$p->{type} = $reftype eq 'array' ? 'arrayref' :
5251						$reftype eq 'hash' ? 'hashref' :
5252						'scalar';
5253	6				15	$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				6	$p->{type} = 'object';
5258	3				5	$p->{isa} = $1;
5259	3				11	$self->_log(" CODE: $param is object of class $1");
5260						}
5261						# Blessed references
5262						elsif ($code =~ /bless\s+.*\$$param/) {
5263	4				7	$p->{type} = 'object';
5264	4				7	$self->_log(" CODE: $param is blessed object");
5265						}
5266						# Array/hash operations
5267	230	100			532	if (!$p->{type}) {
5268	198	50 100	67 33		8567	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				4	$p->{type} = 'hashref';
5272						}
5273						}
5274
5275						# Infer type from the default value if type is unknown
5276	230	100	100		725	if (!$p->{type} && exists $p->{_default}) {
5277	22				21	my $default = $p->{_default};
5278	22	50 50			49	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	230	100			418	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		16385	if ($code =~ /\blooks_like_number\s$\s\$$param\s*$/) {
5298	2				3	$p->{type} = 'number';
5299	2				4	$p->{_type_confidence} = 'heuristic';
5300	2				4	$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				86	$p->{type} = 'number';
5311	55				89	$p->{_type_confidence} = 'heuristic';
5312	55				112	$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				36	$p->{type} = 'number';
5320	21				49	$p->{_type_confidence} = 'heuristic';
5321	21				43	$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	227			227	1714	my ($self, $p_ref, $param, $code) = @_;
5359
5360						# Dereference once to get the hash reference
5361	227				236	my $p = $$p_ref;
5362
5363						# Now pass the dereferenced hash to the detection methods
5364	227				521	$self->_detect_datetime_type($p, $param, $code);
5365	227				718	$self->_detect_filehandle_type($p, $param, $code);
5366	227				616	$self->_detect_coderef_type($p, $param, $code);
5367	227				526	$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	228			228	314	my ($self, $p, $param, $code) = @_;
5394
5395						# Validate param is just a simple word
5396	228	50	33		757	return unless defined $param && $param =~ /^\w+$/;
5397
5398						# DateTime object detection via isa/UNIVERSAL checks
5399	228	100			6813	if ($code =~ /\$$param\s->\sisa\s$\s['"]DateTime['"]\s*$/i) {
5400	2				3	$p->{type} = 'object';
5401	2				4	$p->{isa} = 'DateTime';
5402	2				2	$p->{semantic} = 'datetime_object';
5403	2				6	$self->_log(" ADVANCED: $param is DateTime object");
5404	2				3	return;
5405						}
5406
5407						# Check for DateTime method calls
5408	226	100			4174	if ($code =~ /\$$param\s->\s(ymd\|dmy\|mdy\|hms\|iso8601\|epoch\|strftime)/) {
5409	1				2	$p->{type} = 'object';
5410	1				1	$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	225	50	33		9195	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	225	100			2628	if ($code =~ /\$$param\s=~\s\/.?\\d\{4\}.?\\d\{2\}.*?\\d\{2\}/) {
5428	1				2	$p->{type} = 'string';
5429	1				1	$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	224	100			2663	if ($code =~ /\$$param\s=~\s\/.?[Tt].?[Zz].*?\//) {
5437	1				2	$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				2	$self->_log(" ADVANCED: $param validated as ISO 8601 datetime");
5441	1				2	return;
5442						}
5443
5444						# UNIX timestamp detection (numeric with specific range)
5445	223	50	50		8441	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				5	$p->{type} = 'integer';
5449	2				3	$p->{semantic} = 'unix_timestamp';
5450	2				3	$p->{min} = 0;
5451	2				6	$self->_log(" ADVANCED: $param appears to be UNIX timestamp");
5452	2				4	return;
5453						}
5454
5455						# Date parsing with strptime or similar
5456	221	50	33		7627	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	228			228	318	my ($self, $p, $param, $code) = @_;
5488
5489	228	50	33		651	return unless defined $param && $param =~ /^\w+$/;
5490
5491						# File handle operations
5492	228	100			5444	if ($code =~ /(?:open\|close\|read\|print\|say\|sysread\|syswrite)\s\(?\s\$$param/) {
5493	2				4	$p->{type} = 'object';
5494	2				4	$p->{isa} = 'IO::Handle';
5495	2				3	$p->{semantic} = 'filehandle';
5496	2				6	$self->_log(" ADVANCED: $param is a file handle");
5497	2				3	return;
5498						}
5499
5500						# Filehandle-specific operations
5501	226	100			4109	if ($code =~ /\$$param\s->\s(readline\|getline\|print\|say\|close\|flush\|autoflush)/) {
5502	1				2	$p->{type} = 'object';
5503	1				1	$p->{isa} = 'IO::Handle';
5504	1				2	$p->{semantic} = 'filehandle';
5505	1				2	$self->_log(" ADVANCED: $param uses filehandle methods");
5506	1				1	return;
5507						}
5508
5509						# File test operators
5510	225	100			2894	if ($code =~ /(?:-[frwxoOeszlpSbctugkTBMAC])\s+\$$param/) {
5511	3				9	$p->{type} = 'string';
5512	3				5	$p->{semantic} = 'filepath';
5513	3				9	$self->_log(" ADVANCED: $param is tested as file path");
5514	3				6	return;
5515						}
5516
5517						# File::Spec operations or path manipulation
5518	222	50	33		8506	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	222	50	67		560	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	222	50	33		8843	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	229			229	300	my ($self, $p, $param, $code) = @_;
5568
5569	229	50	33		671	return unless defined $param && $param =~ /^\w+$/;
5570
5571						# ref() check for CODE
5572	229	100			6320	if ($code =~ /ref\s$\s\$$param\s$\seq\s*['"]CODE['"]/i) {
5573	2				4	$p->{type} = 'coderef';
5574	2				4	$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	227	50	50		8415	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				3	$p->{semantic} = 'callback';
5585	2				5	$self->_log(" ADVANCED: $param invoked as coderef");
5586	2				3	return;
5587						}
5588
5589						# Parameter name suggests callback
5590	225	100			573	if ($param =~ /^(?:callback\|cb\|handler\|sub\|code\|fn\|func\|on_\w+)$/i) {
5591	2				4	$p->{type} = 'coderef';
5592	2				3	$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	223	50	33		3054	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	229			229	317	my ($self, $p, $param, $code) = @_;
5636
5637	229	50	33		639	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	229	100			3543	if ($code =~ /unless\s+\$$param\s=~\s\/\^?$([^)]+)$/) {
5642	4				5	my $values = $1;
5643	4				10	my @enum_values = split(/\\|/, $values);
5644	4	100			12	$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				7	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	225	100			459	if ($code =~ /\%(\w+)\s=.?qw\s*[$\[<{]([^)\]>}]+)[$\]>}]/) {
5655	3				8	my $hash_name = $1;
5656	3				3	my $values_str = $2;
5657	3	100	67		49	if (defined $values_str && $code =~ /\$$hash_name\s\{\s\$$param\s*\}/) {
5658	2				4	my @enum_values = split(/\s+/, $values_str);
5659	2	50			7	$p->{type} = 'string' unless $p->{type};
5660	2				3	$p->{enum} = \@enum_values;
5661	2				5	$p->{semantic} = 'enum';
5662	2				7	$self->_log(" ADVANCED: $param validated via hash lookup: " . join(', ', @enum_values));
5663	2				3	return;
5664						}
5665						}
5666
5667						# Pattern 3: Array grep validation
5668						# die unless grep { $_ eq $param } qw(foo bar baz);
5669	223	100			5395	if ($code =~ /grep\s\{[^}]\$$param[^}]\}\sqw\s*[$\[<{]([^)\]>}]+)[$\]>}]/) {
5670	1				2	my $values_str = $1;
5671	1				3	my @enum_values = split(/\s+/, $values_str);
5672	1	50			3	$p->{type} = 'string' unless $p->{type};
5673	1				1	$p->{enum} = \@enum_values;
5674	1				2	$p->{semantic} = 'enum';
5675	1				3	$self->_log(" ADVANCED: $param validated via grep: " . join(', ', @enum_values));
5676	1				2	return;
5677						}
5678
5679						# Pattern 4: Given/when (Perl 5.10+)
5680	222	100			2943	if ($code =~ /given\s$\s\$$param\s*$/) {
5681	1				1	my @enum_values;
5682	1				6	while ($code =~ /when\s$\s['"]([^'"]+)['"]\s*$/g) {
5683	2				6	push @enum_values, $1;
5684						}
5685	1	50			4	if (@enum_values >= 2) {
5686	1	50			3	$p->{type} = 'string' unless $p->{type};
5687	1				17	$p->{enum} = \@enum_values;
5688	1				2	$p->{semantic} = 'enum';
5689	1				5	$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	221				249	my @if_values;
5697	221				6068	while ($code =~ /if\s$\s\$$param\seq\s['"]([^'"]+)['"]\s*$/g) {
5698	10				26	push @if_values, $1;
5699						}
5700	221				6028	while ($code =~ /elsif\s$\s\$$param\seq\s['"]([^'"]+)['"]\s*$/g) {
5701	7				17	push @if_values, $1;
5702						}
5703	221	100			380	if (@if_values >= 3) {
5704	3	50			11	$p->{type} = 'string' unless $p->{type};
5705	3				4	$p->{enum} = \@if_values;
5706	3				6	$p->{semantic} = 'enum';
5707	3				13	$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	218	50	33		7429	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	229			229	331	my ($self, $p, $param, $code) = @_;
5756
5757						# Look for die/croak/confess with a condition involving this param
5758	229				676	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		74	my $message = $1 \|\| $2;
5773	37				44	my $condition = $3;
5774
5775						# Only keep conditions that reference this parameter
5776	37	100			177	next unless $condition =~ /\$$param\b/;
5777
5778						# Initialize storage
5779	24		100		83	$$p->{_invalid} \|\|= [];
5780	24		100		56	$$p->{_errors} \|\|= [];
5781
5782						# Normalize condition (strip surrounding parens)
5783	24				75	$condition =~ s/^$\|$$//g;
5784	24				61	$condition =~ s/\s+/ /g;
5785
5786						# Try to extract a meaningful invalid constraint
5787	24				23	my $constraint;
5788
5789						# Examples:
5790						# $age <= 0
5791						# $x eq ''
5792						# length($s) < 3
5793	24	100 100 50			1069	if ($condition =~ /\$$param\s([!<>=]=?\|eq\|ne\|lt\|gt\|le\|ge)\s(.+)/) {
5794	8				20	$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			58 15	push @{ $$p->{_invalid} }, $constraint if $constraint;
5805	24 19	100			37 27	push @{ $$p->{_errors} }, $message if defined $message;
5806
5807	24	100			81	$self->_log(
5808						" ERROR: $param invalid when [$condition]" .
5809						(defined $message ? " => '$message'" : '')
5810						);
5811						}
5812
5813						# Numeric comparison with literal
5814	229	100			4508	if ($code =~ /\b\Q$param\E\s(<=\|<\|>=\|>)\s(-?\d+)/) {
5815	19				39	my ($op, $num) = ($1, $2);
5816
5817						# Mark required
5818	19				37	$$p->{optional} = 0;
5819
5820	19	100 100 100 50			69	if ($op eq '<=') {
5821	1				2	$$p->{min} = $num + 1;
5822						} elsif ($op eq '<') {
5823	5				13	$$p->{min} = $num;
5824						} elsif ($op eq '>=') {
5825	1				2	$$p->{max} = $num - 1;
5826						} elsif ($op eq '>') {
5827	12				25	$$p->{max} = $num;
5828						}
5829
5830	19				50	$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	668			668	798	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	668	100			2219	if ($code =~ /sub\s+\w+\s(?::\w+(?:$[^)]$)?\s)$((?:[^()]\|\([^)]$))\)\s*\{/s) {
5875	28				39	my $potential_sig = $1;
5876
5877						# Check if this looks like parameters (has sigils)
5878	28	100			56	if ($potential_sig =~ /[\$\%\@]/) {
5879	24				50	$self->_log(" SIG: Found modern signature: ($potential_sig)");
5880	24				63	$self->_parse_modern_signature($params, $potential_sig);
5881	24				26	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	644	100			1047	if($code =~ /my\s+\$(?:self\|class)\s=\s\$_\[0\]/) {
5889	22				29	my $pos = 0;
5890	22				88	while($code =~ /my\s+\$(\w+)\s=\s\$_\[(\d+)\]/g) {
5891	24				34	my $name = $1;
5892	24	100			90	next if $name =~ /^(self\|class)$/i;
5893	2		50		18	$params->{$name} //= { _source => 'code', optional => 1, position => $pos++ };
5894	2				6	$self->_log(" CODE: Found direct-index parameter '\$$name' at \$_[$2]");
5895						}
5896	22				35	return;
5897						}
5898
5899						# Traditional Style 1: my ($self, $arg1, $arg2) = @_;
5900	622	100 100			1581	if ($code =~ /my\s$\s([^)]+)$\s=\s\@_/s) {
5901	337				521	my $sig = $1;
5902	337				308	my $pos = 0;
5903
5904	337				913	while ($sig =~ /\$(\w+)/g) {
5905	708				656	my $name = $1;
5906
5907	708	100			1312	next if $name =~ /^(self\|class)$/i;
5908
5909	393		50		1421	$params->{$name} //= {
5910						_source => 'code',
5911						optional => 1,
5912						};
5913
5914	393	50			855	$params->{$name}{position} = $pos unless exists $params->{$name}{position};
5915
5916	393				507	$pos++;
5917						}
5918	337				441	return;
5919						} elsif ($code =~ /my\s+\$self\s=\sshift/) {
5920						# Traditional Style 2: my $self = shift; my $arg1 = shift;
5921	32				38	my @shifts;
5922	32				106	while ($code =~ /my\s+\$(\w+)\s=\sshift/g) {
5923	39				86	push @shifts, $1;
5924						}
5925	32	50	33		133	shift @shifts if @shifts && $shifts[0] =~ /^(self\|class)$/i;
5926	32				36	my $pos = 0;
5927	32				44	foreach my $param (@shifts) {
5928	7		50		33	$params->{$param} \|\|= { _source => 'code', optional => 1, position => $pos++ };
5929						}
5930	32				52	return;
5931						}
5932
5933						# Traditional Style 3: Function parameters (no $self)
5934	253	50			261	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)$/i;
5940	0		0		0	$params->{$param} \|\|= { _source => 'code', optional => 1, position => $pos++ };
5941						}
5942						}
5943
5944						# De-duplicate
5945	253				199	my %seen;
5946	253				305	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	3171	my ($self, $params, $sig) = @_;
5974
5975	26				54	$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				1595	require Text::Balanced;
5980	26				12492	my @parts;
5981	26				38	my $current = '';
5982	26				31	my $rest = $sig;
5983
5984	26				43	while (length $rest) {
5985	743	100			633	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				10	my $extracted = Text::Balanced::extract_bracketed($rest, '(){}[]');
5989	3	50			416	last unless defined $extracted; # Unbalanced brackets
5990	3				3	$current .= $extracted;
5991	3				7	next;
5992						}
5993	740	100			604	if (substr($rest, 0, 1) eq ',') {
5994	47				43	push @parts, $current;
5995	47				39	$current = '';
5996	47				44	$rest = substr($rest, 1);
5997	47				43	next;
5998						}
5999	693				458	$current .= substr($rest, 0, 1);
6000	693				542	$rest = substr($rest, 1);
6001						}
6002	26	50			64	push @parts, $current if $current =~ /\S/;
6003
6004	26				29	my $position = 0;
6005
6006	26				34	foreach my $part (@parts) {
6007	73				207	$part =~ s/^\s+\|\s+$//g;
6008
6009						# Skip empty parts
6010	73	50			78	next unless $part;
6011
6012						# Parse different parameter types
6013	73				92	my $param_info = $self->_parse_signature_parameter($part, $position);
6014
6015	73	50			80	if ($param_info) {
6016	73				61	my $name = $param_info->{name};
6017
6018						# Skip self/class
6019	73	100			113	if ($name =~ /^(self\|class)$/i) {
6020	18				31	next;
6021						}
6022
6023	55				65	$params->{$name} = $param_info;
6024						$self->_log(" SIG: $name has position $position" .
6025						($param_info->{optional} ? ' (optional)' : '') .
6026	55	100 100			168	($param_info->{_default} ? ", default: $param_info->{_default}" : ''));
6027	55				78	$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	6148	my ($self, $part, $position) = @_;
6063
6064	86				136	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			353	if ($part =~ /^\$(\w+)\s:\s(\w+)\s=\s(.+)$/s) {
6072	7				18	my ($name, $constraint, $default) = ($1, $2, $3);
6073	7				13	$default =~ s/^\s+\|\s+$//g;
6074
6075	7				14	$info{name} = $name;
6076	7				20	$info{optional} = 1;
6077	7				18	$info{_default} = $self->_clean_default_value($default, 1);
6078
6079						# Apply type constraint
6080	7	100 100 50 0 0 0			31	if ($constraint =~ /^(Int\|Integer)$/i) {
6081	2				4	$info{type} = 'integer';
6082						} elsif ($constraint =~ /^(Num\|Number)$/i) {
6083	3				6	$info{type} = 'number';
6084						} elsif ($constraint =~ /^(Str\|String)$/i) {
6085	2				3	$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				10	return \%info;
6098						} elsif ($part =~ /^\$(\w+)\s:\s(\w+)\s*$/s) {
6099						# Pattern 2: Type constraint WITHOUT default: $name :Type
6100	14				27	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			71	if ($constraint =~ /^(Int\|Integer)$/i) {
6106	4				7	$info{type} = 'integer';
6107						} elsif ($constraint =~ /^(Num\|Number)$/i) {
6108	2				3	$info{type} = 'number';
6109						} elsif ($constraint =~ /^(Str\|String)$/i) {
6110	2				3	$info{type} = 'string';
6111						} elsif ($constraint =~ /^(Bool\|Boolean)$/i) {
6112	2				4	$info{type} = 'boolean';
6113						} elsif ($constraint =~ /^(Array\|ArrayRef)$/i) {
6114	2				18	$info{type} = 'arrayref';
6115						} elsif ($constraint =~ /^(Hash\|HashRef)$/i) {
6116	0				0	$info{type} = 'hashref';
6117						} else {
6118	2				3	$info{type} = 'object';
6119	2				3	$info{isa} = $constraint;
6120						}
6121
6122	14				20	return \%info;
6123						} elsif ($part =~ /^\$(\w+)\s=\s(.+)$/s) {
6124						# Pattern 3: Default WITHOUT type: $name = default
6125	16				32	my ($name, $default) = ($1, $2);
6126	16				30	$default =~ s/^\s+\|\s+$//g;
6127
6128	16				20	$info{name} = $name;
6129	16				16	$info{optional} = 1;
6130	16				39	$info{_default} = $self->_clean_default_value($default, 1);
6131	16	50			69	$info{type} = $self->_infer_type_from_default($info{_default}) if $self->can('_infer_type_from_default');
6132
6133	16				19	return \%info;
6134						}
6135
6136						# Pattern 4: Plain parameter: $name
6137						elsif ($part =~ /^\$(\w+)$/s) {
6138	39				55	$info{name} = $1;
6139	39				39	$info{optional} = 0;
6140	39				48	return \%info;
6141						}
6142
6143						# Pattern 5: Array parameter: @name
6144						elsif ($part =~ /^\@(\w+)$/s) {
6145	4				8	$info{name} = $1;
6146	4				7	$info{type} = 'array';
6147	4				7	$info{slurpy} = 1;
6148	4				7	$info{optional} = 1;
6149	4				6	return \%info;
6150						}
6151
6152						# Pattern 6: Hash parameter: %name
6153						elsif ($part =~ /^\%(\w+)$/s) {
6154	4				7	$info{name} = $1;
6155	4				8	$info{type} = 'hash';
6156	4				5	$info{slurpy} = 1;
6157	4				6	$info{optional} = 1;
6158	4				7	return \%info;
6159						}
6160
6161	2				6	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	67	my ($self, $default) = @_;
6184
6185	33	100			43	return undef unless defined $default;
6186
6187	29	100 100 100 100 50	33		122	if (ref($default) eq 'HASH') {
6188	2				6	return 'hashref';
6189						} elsif (ref($default) eq 'ARRAY') {
6190	2				4	return 'arrayref';
6191						} elsif ($default =~ /^-?\d+$/) {
6192	16				32	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				16	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	336			336	2178	my ($self, $code) = @_;
6223
6224	336				330	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	336				443	my $attr_section = '';
6233
6234	336	100			909	if($code =~ /sub\s+\w+\s+((?::\w+(?:$[^)]$)?\s)+)/s) {
6235	9				15	$attr_section = $1;
6236						}
6237
6238						# Parse individual attributes from the section
6239	336	100			517	if($attr_section) {
6240	9				32	while($attr_section =~ /:(\w+)(?:$([^)]*)$)?/g) {
6241	11				21	my ($name, $value) = ($1, $2);
6242
6243	11	100	67		29	if (defined $value && $value ne '') {
6244	5				10	$attributes{$name} = $value;
6245	5				11	$self->_log(" ATTR: Found attribute :$name($value)");
6246						} else {
6247	6				10	$attributes{$name} = 1;
6248	6				11	$self->_log(" ATTR: Found attribute :$name");
6249						}
6250						}
6251						}
6252
6253						# Process common attributes
6254	336	100			572	if ($attributes{Returns}) {
6255	4				6	my $return_type = $attributes{Returns};
6256	4	50			9	if ($return_type ne '1') { # Only log if it's an actual type, not just the flag
6257	4				25	$self->_log(" ATTR: Method declares return type: $return_type");
6258						}
6259						}
6260
6261	336	100			554	if ($attributes{lvalue}) {
6262	4				6	$self->_log(" ATTR: Method is lvalue (can be assigned to)");
6263						}
6264
6265	336	100			555	if ($attributes{method}) {
6266	2				5	$self->_log(' ATTR: Method explicitly marked as :method');
6267						}
6268
6269	336				448	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	338			338	1617	my ($self, $code) = @_;
6295
6296	338				337	my %derefs;
6297
6298						# Array dereference: $ref->@*
6299	338	100			937	if ($code =~ /\$\w+\s->\s\@\*/) {
6300	4				9	$derefs{array_deref} = 1;
6301	4				7	$self->_log(" MODERN: Uses postfix array dereferencing (->@*)");
6302						}
6303
6304						# Hash dereference: $ref->%*
6305	338	100			855	if ($code =~ /\$\w+\s->\s\%\*/) {
6306	3				6	$derefs{hash_deref} = 1;
6307	3				7	$self->_log(" MODERN: Uses postfix hash dereferencing (->%*)");
6308						}
6309
6310						# Scalar dereference: $ref->$*
6311	338	100			797	if ($code =~ /\$\w+\s->\s\$\*/) {
6312	2				4	$derefs{scalar_deref} = 1;
6313	2				3	$self->_log(' MODERN: Uses postfix scalar dereferencing (->$*)');
6314						}
6315
6316						# Code dereference: $ref->&*
6317	338	100			749	if ($code =~ /\$\w+\s->\s\&\*/) {
6318	1				1	$derefs{code_deref} = 1;
6319	1				1	$self->_log(" MODERN: Uses postfix code dereferencing (->&*)");
6320						}
6321
6322						# Array element: $ref->@[0,2,4]
6323	338	100			749	if ($code =~ /\$\w+\s->\s\@\[/) {
6324	2				4	$derefs{array_slice} = 1;
6325	2				5	$self->_log(" MODERN: Uses postfix array slice (->@[...])");
6326						}
6327
6328						# Hash element: $ref->%{key1,key2}
6329	338	100			795	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	338				431	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	339			339	2791	my ($self, $code) = @_;
6360
6361	339				327	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	339				774	while ($code =~ /^\sfield\s+\$(\w+)\s([^;]*);/gm) {
6368	12				22	my ($name, $modifiers) = ($1, $2);
6369
6370	12				27	$self->_log(" FIELD: Found field \$$name with modifiers: [$modifiers]");
6371
6372	12				22	my %field_info = (
6373						name => $name,
6374						_source => 'field'
6375						);
6376
6377						# Check for :param attribute
6378	12	100			48	if ($modifiers =~ /:param(?:$([^)]+)$)?/) {
6379	11				14	$field_info{is_param} = 1;
6380
6381	11	100			19	if (defined $1) {
6382						# Explicit parameter name
6383	2				4	$field_info{param_name} = $1;
6384						} else {
6385						# Implicit - field name is param name
6386	9				14	$field_info{param_name} = $name;
6387						}
6388
6389	11				18	$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			22	if ($modifiers =~ /=\s*([^:;]+)(?::\|;\|$)/) {
6394	4				5	my $default = $1;
6395	4				8	$default =~ s/\s+$//;
6396	4				12	$field_info{_default} = $self->_clean_default_value($default, 1);
6397	4				7	$field_info{optional} = 1;
6398	4	50			14	$self->_log(" FIELD: $name has default: " . (defined $field_info{_default} ? $field_info{_default} : 'undef'));
6399						}
6400
6401						# Check for type constraints
6402	12	100			23	if ($modifiers =~ /:isa$([^)]+)$/) {
6403	3				7	$field_info{isa} = $1;
6404	3				5	$field_info{type} = 'object';
6405	3				13	$self->_log(" FIELD: $name has type constraint: $1");
6406						}
6407
6408	12				27	$fields{$name} = \%field_info;
6409						}
6410
6411	339				397	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	39	my ($self, $params, $fields) = @_;
6444
6445	6				12	foreach my $field_name (keys %$fields) {
6446	11				12	my $field = $fields->{$field_name};
6447
6448						# Only process fields that are parameters
6449	11	100			17	next unless $field->{is_param};
6450
6451	9				11	my $param_name = $field->{param_name};
6452
6453						# Create or update parameter info
6454	9		50		37	$params->{$param_name} \|\|= {};
6455	9				10	my $p = $params->{$param_name};
6456
6457						# Merge field information into parameter
6458	9	50			15	$p->{_source} = 'field' unless $p->{_source};
6459	9	100			15	$p->{field_name} = $field_name if $field_name ne $param_name;
6460
6461	9	100			12	if ($field->{_default}) {
6462	3				4	$p->{_default} = $field->{_default};
6463	3				3	$p->{optional} = 1;
6464						}
6465
6466	9	100			13	if ($field->{isa}) {
6467	2				4	$p->{isa} = $field->{isa};
6468	2				4	$p->{type} = 'object';
6469						}
6470
6471	9				18	$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	336			336	503	my ($self, $params, $code, $method) = @_;
6507
6508						# Pattern 1: my $param = value;
6509	336				869	while ($code =~ /my\s+\$(\w+)\s=\s([^;]+);/g) {
6510	77				150	my ($param, $value) = ($1, $2);
6511	77	100			162	next unless exists $params->{$param};
6512	3	50			7	next if $value =~ /->/; # deref/method call, not a default value
6513
6514	3				10	$params->{$param}{_default} = $self->_clean_default_value($value, 1);
6515	3				6	$params->{$param}{optional} = 1;
6516	3				11	$self->_log(" CODE: $param has default: " . $self->_format_default($params->{$param}{_default}));
6517						}
6518
6519						# Pattern 2: $param = value unless defined $param;
6520	336				1030	while ($code =~ /\$(\w+)\s=\s([^;]+?)\s+unless\s+(?:defined\s+)?\$\1/g) {
6521	4				8	my ($param, $value) = ($1, $2);
6522	4	50			10	next unless exists $params->{$param};
6523
6524	4				9	$params->{$param}{_default} = $self->_clean_default_value($value, 1);
6525	4				6	$params->{$param}{optional} = 1;
6526	4				14	$self->_log(" CODE: $param has default (unless): " . $self->_format_default($params->{$param}{_default}));
6527						}
6528
6529						# Pattern 3: $param = value unless $param;
6530	336				980	while ($code =~ /\$(\w+)\s=\s([^;]+?)\s+unless\s+\$\1/g) {
6531	1				2	my ($param, $value) = ($1, $2);
6532	1	50			2	next unless exists $params->{$param};
6533
6534	1				2	$params->{$param}{_default} = $self->_clean_default_value($value, 1);
6535	1				2	$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	336				731	while ($code =~ /\$(\w+)\s=\s\$\1\s\\|\\|\s([^;]+);/g) {
6541	8				14	my ($param, $value) = ($1, $2);
6542	8	50			12	next unless exists $params->{$param};
6543
6544	8				14	$params->{$param}{_default} = $self->_clean_default_value($value, 1);
6545	8				8	$params->{$param}{optional} = 1;
6546	8				20	$self->_log(" CODE: $param has default (\|\|): " . $self->_format_default($params->{$param}{_default}));
6547						}
6548
6549						# Pattern 5: $param \|\|= 'default';
6550	336				753	while ($code =~ /\$(\w+)\s\\|\\|=\s([^;]+);/g) {
6551	3				8	my ($param, $value) = ($1, $2);
6552	3	50			7	next unless exists $params->{$param};
6553
6554	3				9	$params->{$param}{_default} = $self->_clean_default_value($value, 1);
6555	3				6	$params->{$param}{optional} = 1;
6556	3				11	$self->_log(" CODE: $param has default (\|\|=): " . $self->_format_default($params->{$param}{_default}));
6557						}
6558
6559						# Pattern 6: $param //= 'default';
6560	336				711	while ($code =~ /\$(\w+)\s\/\/=\s([^;]+);/g) {
6561	8				14	my ($param, $value) = ($1, $2);
6562	8	100			18	next unless exists $params->{$param}; # Using -> because $params is a reference
6563
6564	7				12	$params->{$param}{_default} = $self->_clean_default_value($value, 1);
6565
6566	7				10	$params->{$param}{optional} = 1;
6567	7				18	$self->_log(" CODE: $param has default (//=): " . $self->_format_default($params->{$param}{_default}));
6568						}
6569
6570						# Pattern 7: $param = defined $param ? $param : 'default';
6571	336				759	while ($code =~ /\$(\w+)\s=\sdefined\s+\$\1\s\?\s\$\1\s:\s([^;]+);/g) {
6572	4				7	my ($param, $value) = ($1, $2);
6573
6574						# Create param entry if it doesn't exist
6575	4		50		8	$params->{$param} \|\|= {};
6576
6577	4				6	my $cleaned = $self->_clean_default_value($value, 1);
6578
6579	4				8	$params->{$param}{_default} = $cleaned;
6580	4				4	$params->{$param}{optional} = 1;
6581	4				9	$self->_log(" CODE: $param has default (ternary): " . $self->_format_default($params->{$param}{_default}));
6582						}
6583
6584						# Pattern 8: $param = $args{param} \|\| 'default';
6585	336				701	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	336				682	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				2	$params->{$param}{optional} = 1;
6602	1				2	$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	336	100	100		312	if (!keys %{$params} && $code !~ /my\s+\$(?:self\|class)\s=\s\$_\[0\]/) {
6612	167				142	my $position = 0;
6613
6614						# Style 1: my ($a, $b) = @_;
6615	167				330	while ($code =~ /my\s$\s([^)]+)\s$\s=\s*\@_/g) {
6616	30				85	my @vars = $1 =~ /\$(\w+)/g;
6617	30				69	foreach my $var (@vars) {
6618	30	100 50	50 25		161	if(($var eq 'class') && ($position == 0) && ($method->{name} eq 'new')) {
6619						# Don't include "class" in the variable names of the constructor
6620	17				35	delete $params->{'class'};
6621						} elsif(($var eq 'self') && ($position == 0) && ($method->{name} ne 'new')) {
6622						# Don't include "self" in the variable names
6623	13				23	delete $params->{'self'};
6624						} else {
6625	0		0		0	$params->{$var} \|\|= { position => $position++ };
6626	0				0	$self->_log(" CODE: $var extracted from \@_ list assignment");
6627						}
6628						}
6629						}
6630
6631						# Style 2: my $x = shift;
6632	167				306	while ($code =~ /my\s+\$(\w+)\s=\sshift\b/g) {
6633	13				16	my $var = $1;
6634	13	100 100	50 50		105	if(($var eq 'class') && ($position == 0) && ($method->{name} eq 'new')) {
6635						# Don't include "class" in the variable names of the constructor
6636	1				3	delete $params->{'class'};
6637						} elsif(($var eq 'self') && ($position == 0) && ($method->{name} ne 'new')) {
6638						# Don't include "self" in the variable names
6639	11				16	delete $params->{'self'};
6640						} else {
6641	1		50		4	$params->{$var} \|\|= { position => $position++ };
6642	1				2	$self->_log(" CODE: $var is extracted from shift");
6643						}
6644						}
6645
6646						# Style 3: my $x = $_[0];
6647	167				330	while ($code =~ /my\s+\$(\w+)\s=\s\$_\[(\d+)\]/g) {
6648	0				0	my ($var, $index) = ($1, $2);
6649	0	0	0		0	if(($var ne 'class') \|\| ($position > 0) \|\| ($method->{name} ne 'new')) {
6650	0		0		0	$params->{$var} \|\|= { position => $index };
6651	0				0	$self->_log(" CODE: $var is extracted from \$_\[$index\]");
6652						}
6653						}
6654						}
6655						}
6656
6657						# --------------------------------------------------
6658						# _format_default
6659						#
6660						# Purpose: Format a default value for display
6661						# in verbose log output.
6662						#
6663						# Entry: $default - the default value to
6664						# format. May be undef,
6665						# a scalar, a hashref, or
6666						# an arrayref.
6667						#
6668						# Exit: Returns a display string: 'undef'
6669						# for undef, 'HASH ref' / 'ARRAY ref'
6670						# for references, or the value itself
6671						# for scalars.
6672						#
6673						# Side effects: None.
6674						# --------------------------------------------------
6675						sub _format_default {
6676	35			35	48	my ($self, $default) = @_;
6677	35	100			62	return 'undef' unless defined $default;
6678	32	100			50	return ref($default) . ' ref' if ref($default);
6679	27				46	return $default;
6680						}
6681
6682						# --------------------------------------------------
6683						# _module_constants
6684						#
6685						# Purpose: Build and cache a hash of numeric
6686						# constant values declared in the target
6687						# module source, covering both Readonly
6688						# lexicals and 'use constant' barewords.
6689						# Used by _analyze_parameter_constraints
6690						# to resolve right-hand sides like
6691						# $MIN_NAME_LEN that are not literals.
6692						#
6693						# Entry: None (uses $self->{_document}).
6694						#
6695						# Exit: Returns a hashref { NAME => value }.
6696						# Returns {} if the PPI document is not
6697						# yet loaded.
6698						#
6699						# Side effects: Caches result in $self->{_constants}.
6700						# --------------------------------------------------
6701						sub _module_constants {
6702	6			6	6	my ($self) = @_;
6703	6	100			11	return $self->{_constants} if exists $self->{_constants};
6704
6705	2				2	my %c;
6706	2				3	my $doc = $self->{_document};
6707	2	50			5	unless ($doc) {
6708	0				0	$self->{_constants} = \%c;
6709	0				0	return \%c;
6710						}
6711
6712	2				7	my $src = $doc->serialize();
6713
6714						# Readonly my $CONST => numeric_value;
6715	2				5184	while ($src =~ /Readonly\s+(?:my\|our)\s+\$(\w+)\s=>\s([+-]?\d+(?:\.\d+)?)/g) {
6716	10				29	$c{$1} = $2;
6717						}
6718
6719						# use constant CONST => numeric_value;
6720	2				15	while ($src =~ /use\s+constant\s+(\w+)\s=>\s([+-]?\d+(?:\.\d+)?)/g) {
6721	0				0	$c{$1} = $2;
6722						}
6723
6724	2				5	$self->{_constants} = \%c;
6725	2				4	return \%c;
6726						}
6727
6728						# --------------------------------------------------
6729						# _analyze_parameter_constraints
6730						#
6731						# Purpose: Infer min, max, and regex match
6732						# constraints for a single parameter
6733						# from length checks, numeric
6734						# comparisons, and regex match
6735						# patterns in the method body.
6736						#
6737						# Entry: $p_ref - reference to the parameter
6738						# hashref (modified in place).
6739						# $param - parameter name string.
6740						# $code - method body source string.
6741						#
6742						# Exit: Returns nothing. Modifies the
6743						# referenced parameter hashref.
6744						#
6745						# Side effects: Logs detections to stdout when
6746						# verbose is set.
6747						#
6748						# Notes: Numeric comparisons that appear
6749						# inside die/croak guard conditions
6750						# are excluded to avoid inferring
6751						# invalid-input ranges as valid
6752						# constraints.
6753						# --------------------------------------------------
6754						sub _analyze_parameter_constraints {
6755	229			229	340	my ($self, $p_ref, $param, $code) = @_;
6756	229				244	my $p = $$p_ref;
6757
6758						# Do not treat comparisons inside die/croak/confess as valid constraints
6759	229				210	my $guarded = 0;
6760	229	100			5273	if ($code =~ /(die\|croak\|confess)\b[^{;]\bif\b[^{;]\$$param\b/s) {
6761	24				22	$guarded = 1;
6762						}
6763
6764						# Length checks for strings â€” literal numeric RHS
6765	229	100			5500	if ($code =~ /length\s$\s\$$param\s$\s([<>]=?)\s*(\d+)/) {
6766	4				9	my ($op, $val) = ($1, $2);
6767	4		50		15	$p->{type} \|\|= 'string';
6768	4	100 50 100 50			13	if ($op eq '<') {
6769	2				4	$p->{max} = $val - 1;
6770						} elsif ($op eq '<=') {
6771	0				0	$p->{max} = $val;
6772						} elsif ($op eq '>') {
6773	1				3	$p->{min} = $val + 1;
6774						} elsif ($op eq '>=') {
6775	1				2	$p->{min} = $val;
6776						}
6777	4				10	$self->_log(" CODE: $param length constraint $op $val");
6778						}
6779
6780						# Length checks for strings â€” Readonly / use-constant RHS ($CONST_NAME)
6781	229				8743	while ($code =~ /length\s$\s\$$param\s$\s([<>]=?)\s*\$(\w+)/g) {
6782	6				12	my ($op, $const) = ($1, $2);
6783	6				12	my $val = $self->_module_constants()->{$const};
6784	6	50			10	next unless defined $val;
6785	6		100		15	$p->{type} \|\|= 'string';
6786	6	50 100 50 50			18	if ($op eq '<') {
6787	0				0	$p->{max} = $val - 1;
6788						} elsif ($op eq '<=') {
6789	3				6	$p->{max} = $val;
6790						} elsif ($op eq '>') {
6791	0				0	$p->{min} = $val + 1;
6792						} elsif ($op eq '>=') {
6793	3				6	$p->{min} = $val;
6794						}
6795	6				11	$self->_log(" CODE: $param length constraint $op \$$const ($val)");
6796						}
6797
6798						# Numeric range checks (only if NOT part of error guard)
6799	229	100	100		4576	if (
6800						!$guarded
6801						&& $code =~ /\$$param\s([<>]=?)\s([+-]?(?:\d+\.?\d*\|\.\d+))/
6802						) {
6803	14				41	my ($op, $val) = ($1, $2);
6804	14	0	33		103	$p->{type} \|\|= looks_like_number($val) ? 'number' : 'integer';
6805
6806	14	100 50	67 67		63	if ($op eq '<' \|\| $op eq '<=') {
6807						# Only set max if it tightens the range
6808	2	50			5	my $max = ($op eq '<') ? $val - 1 : $val;
6809	2	50	33		8	$p->{max} = $max if !defined($p->{max}) \|\| $max < $p->{max};
6810						} elsif ($op eq '>' \|\| $op eq '>=') {
6811	12	100			23	my $min = ($op eq '>') ? $val + 1 : $val;
6812	12	50	33		69	$p->{min} = $min if !defined($p->{min}) \|\| $min > $p->{min};
6813						}
6814						}
6815
6816						# Regex pattern matching with better capture
6817	229	100			10668	if ($code =~ /\$$param\s=~\s((?:qr?\/[^\/]+\/\|\$[\w:]+\|\$\{\w+\}))/) {
6818	1				2	my $pattern = $1;
6819	1		50		4	$p->{type} \|\|= 'string';
6820
6821						# Clean up the pattern if it's a straightforward regex
6822	1	50			5	if ($pattern =~ /^qr?\/([^\/]+)\/$/) {
6823	1				3	$p->{matches} = "/$1/";
6824						} else {
6825	0				0	$p->{matches} = $pattern;
6826						}
6827	1				3	$self->_log(" CODE: $param matches pattern: $p->{matches}");
6828						}
6829						}
6830
6831						# --------------------------------------------------
6832						# _analyze_parameter_validation
6833						#
6834						# Purpose: Determine optionality and extract
6835						# default values for a single parameter
6836						# by analysing explicit required checks
6837						# (die/croak unless defined) and default
6838						# assignment patterns in the method body.
6839						#
6840						# Entry: $p_ref - reference to the parameter
6841						# hashref (modified in place).
6842						# $param - parameter name string.
6843						# $code - method body source string.
6844						#
6845						# Exit: Returns nothing. Modifies the
6846						# referenced parameter hashref.
6847						#
6848						# Side effects: Logs detections to stdout when
6849						# verbose is set.
6850						#
6851						# Notes: Explicit required checks take highest
6852						# priority and override any default
6853						# value detected earlier.
6854						# --------------------------------------------------
6855						sub _analyze_parameter_validation {
6856	230			230	372	my ($self, $p_ref, $param, $code) = @_;
6857	230				242	my $p = $$p_ref;
6858
6859						# Required/optional checks
6860	230				211	my $is_required = 0;
6861
6862						# Die/croak if not defined
6863	230	100			5941	if ($code =~ /(?:die\|croak\|confess)\s+[^;]*unless\s+(?:defined\s+)?\$$param/s) {
6864	34				43	$is_required = 1;
6865						}
6866
6867						# Extract default values with the new method
6868	230				648	my $default_value = $self->_extract_default_value($param, $code);
6869	230	100	100		422	if (defined $default_value && !exists $p->{_default}) {
6870	3				5	$p->{optional} = 1;
6871	3				4	$p->{_default} = $default_value;
6872
6873						# Try to infer type from default value if not already set
6874	3	50			7	unless ($p->{type}) {
6875	3	50 0 0 0 0	0		8	if (looks_like_number($default_value)) {
6876	3	50			9	$p->{type} = $default_value =~ /\./ ? 'number' : 'integer';
6877						} elsif (ref($default_value) eq 'ARRAY') {
6878	0				0	$p->{type} = 'arrayref';
6879						} elsif (ref($default_value) eq 'HASH') {
6880	0				0	$p->{type} = 'hashref';
6881						} elsif ($default_value eq 'undef') {
6882	0				0	$p->{type} = 'scalar'; # undef can be any scalar
6883						} elsif (defined $default_value && !ref($default_value)) {
6884	0				0	$p->{type} = 'string';
6885						}
6886						}
6887
6888	3	50			12	$self->_log(" CODE: $param has default value: " . (ref($default_value) ? ref($default_value) . ' ref' : $default_value));
6889						}
6890
6891						# Also check for simple default assignment without condition
6892						# Pattern: $param = 'value';
6893	230	100	100 100		4799	if (!$default_value && !exists $p->{_default} && $code =~ /\$$param\s=\s([^;{}]+?)(?:\s*[;}])/s) {
6894	10				19	my $assignment = $1;
6895						# Make sure it's not part of a larger expression
6896	10	100	67		78	if ($assignment !~ /\$$param/ && $assignment !~ /^shift/) {
6897	9				11	my $possible_default = $assignment;
6898	9				14	$possible_default =~ s/\s;\s$//;
6899	9				29	$possible_default = $self->_clean_default_value($possible_default);
6900	9	50			15	if (defined $possible_default) {
6901	9				18	$p->{_default} = $possible_default;
6902	9				12	$p->{optional} = 1;
6903	9				22	$self->_log(" CODE: $param has unconditional default: $possible_default");
6904						}
6905						}
6906						}
6907
6908						# Explicit required check overrides default detection
6909	230	100			470	if ($is_required) {
6910	34				54	$p->{optional} = 0;
6911	34	100			64	delete $p->{_default} if exists $p->{_default};
6912	34				77	$self->_log(" CODE: $param is required (validation check)");
6913						}
6914						}
6915
6916						# --------------------------------------------------
6917						# _merge_parameter_analyses
6918						#
6919						# Purpose: Merge parameter information from POD,
6920						# code, and signature analysis into a
6921						# single authoritative parameter hashref
6922						# for each parameter.
6923						#
6924						# Entry: $pod - hashref of parameters from POD
6925						# analysis.
6926						# $code - hashref of parameters from
6927						# code analysis.
6928						# $sig - hashref of parameters from
6929						# signature analysis (optional,
6930						# defaults to empty hashref).
6931						#
6932						# Exit: Returns a merged hashref of parameter
6933						# name to spec hashref. Each spec has
6934						# all available information combined,
6935						# with POD taking highest priority,
6936						# code second, and signature filling
6937						# remaining gaps.
6938						#
6939						# Side effects: Logs merged parameter details to
6940						# stdout when verbose is set.
6941						#
6942						# Notes: Position is determined by majority
6943						# vote across all sources, with the
6944						# lowest position winning ties. Optional
6945						# status is determined by
6946						# _determine_optional_status. Internal
6947						# _source keys are stripped from the
6948						# merged result.
6949						# --------------------------------------------------
6950						sub _merge_parameter_analyses {
6951	329			329	627	my ($self, $pod, $code, $sig) = @_;
6952
6953	329				324	my %merged;
6954
6955						# Start with all parameters from all sources
6956	329 309				778 500	my %all_params = map { $_ => 1 } (keys %$pod, keys %$code, keys %$sig);
6957
6958	329				537	foreach my $param (keys %all_params) {
6959	231				323	my $p = $merged{$param} = {};
6960
6961						# Collect position from all sources
6962	231				210	my @positions;
6963	231	100	100		510	push @positions, $pod->{$param}{position} if $pod->{$param} && defined $pod->{$param}{position};
6964	231	50	33		383	push @positions, $sig->{$param}{position} if $sig->{$param} && defined $sig->{$param}{position};
6965	231	100	100		668	push @positions, $code->{$param}{position} if $code->{$param} && defined $code->{$param}{position};
6966
6967						# Use the most common position, or lowest if tie
6968	231	100			307	if (@positions) {
6969	223				181	my %pos_count;
6970	223				566	$pos_count{$_}++ for @positions;
6971	223 0	0			384 0	my ($best_pos) = sort { $pos_count{$b} <=> $pos_count{$a} \|\| $a <=> $b } keys %pos_count;
6972	223	50			535	$p->{position} = $best_pos unless(exists($p->{position}));
6973						}
6974
6975						# POD has highest priority for type info and explicit declarations
6976	231	100			361	if ($pod->{$param}) {
6977	83 83				100 185	%$p = (%$p, %{$pod->{$param}});
6978						}
6979
6980						# Code analysis adds concrete evidence (but doesn't override POD explicit types)
6981	231	100			313	if ($code->{$param}) {
6982	226 226				204 372	foreach my $key (keys %{$code->{$param}}) {
6983	1052	100			934	next if $key eq '_source';
6984	831	100			708	next if $key eq 'position';
6985						# Formal input-spec declared this param without a type â€” author
6986						# intentionally left it unconstrained; don't let code heuristics
6987						# silently fill in a type that would cause wrong-type die tests.
6988	610	50	80		806	next if $key eq 'type' && $pod->{$param} && $pod->{$param}{_from_input_spec} && !defined $pod->{$param}{type};
6989
6990						# Only override if POD didn't provide this info or it's a stronger signal
6991	610				491	my $from_pod = exists $pod->{$param};
6992	610	100	83		816	if (!exists $p->{$key} \|\|
6993						($key eq 'type' && $from_pod && $p->{type} eq 'string' &&
6994						$code->{$param}{$key} ne 'string')) {
6995	547				589	$p->{$key} = $code->{$param}{$key};
6996						}
6997						}
6998						}
6999
7000						# Signature fills in remaining gaps
7001	231	50			331	if ($sig->{$param}) {
7002	0 0				0 0	foreach my $key (keys %{$sig->{$param}}) {
7003	0	0			0	next if $key eq '_source';
7004	0	0			0	next if $key eq 'position';
7005	0		0		0	$p->{$key} //= $sig->{$param}{$key};
7006						}
7007						}
7008
7009						# Handle optional field with better logic
7010	231				625	$self->_determine_optional_status($p, $pod->{$param}, $code->{$param});
7011
7012						# Clean up internal fields
7013	231				343	delete $p->{_source};
7014						}
7015
7016						# Debug logging
7017	329	100			591	if ($self->{verbose}) {
7018	2 1		50 50		7 4	foreach my $param (sort { ($merged{$a}{position} \|\| 999) <=> ($merged{$b}{position} \|\| 999) } keys %merged) {
7019	2				2	my $p = $merged{$param};
7020						$self->_log(" MERGED $param: " .
7021						'pos=' . ($p->{position} \|\| 'none') .
7022						", type=" . ($p->{type} \|\| 'none') .
7023	2	50	50 100		9	", optional=" . (defined($p->{optional}) ? $p->{optional} : 'undef'));
7024						}
7025						}
7026
7027	329				724	return \%merged;
7028						}
7029
7030						# --------------------------------------------------
7031						# _determine_optional_status
7032						#
7033						# Purpose: Set the optional field on a merged
7034						# parameter spec based on evidence from
7035						# POD and code analysis, with POD taking
7036						# highest priority.
7037						#
7038						# Entry: $merged_param - the merged parameter
7039						# hashref (modified in
7040						# place).
7041						# $pod_param - parameter spec from
7042						# POD analysis, or undef.
7043						# $code_param - parameter spec from
7044						# code analysis, or undef.
7045						#
7046						# Exit: Returns nothing. Sets or leaves
7047						# $merged_param->{optional}.
7048						#
7049						# Side effects: None.
7050						# --------------------------------------------------
7051						sub _determine_optional_status {
7052	237			237	1360	my ($self, $merged_param, $pod_param, $code_param) = @_;
7053
7054	237	100			347	my $pod_optional = $pod_param ? $pod_param->{optional} : undef;
7055	237	100			345	my $code_optional = $code_param ? $code_param->{optional} : undef;
7056
7057						# Explicit POD declaration wins
7058	237	100 100 100			396	if (defined $pod_optional) {
7059	23				29	$merged_param->{optional} = $pod_optional;
7060						}
7061						# Code validation evidence
7062						elsif (defined $code_optional) {
7063	202				263	$merged_param->{optional} = $code_optional;
7064						}
7065						# Default: if we have any info about the param, assume required
7066						elsif (keys %$merged_param > 0) {
7067	11				15	$merged_param->{optional} = 0;
7068						}
7069						# Otherwise leave undef (unknown)
7070						}
7071
7072
7073						# --------------------------------------------------
7074						# _calculate_input_confidence
7075						#
7076						# Purpose: Calculate a confidence score and level
7077						# for the input parameter analysis,
7078						# based on how much type, constraint,
7079						# and semantic information was inferred
7080						# for each parameter.
7081						#
7082						# Entry: $params - hashref of merged parameter
7083						# specs as produced by
7084						# _merge_parameter_analyses.
7085						#
7086						# Exit: Returns a hashref with keys:
7087						# level - one of: none,
7088						# very_low, low,
7089						# medium, high
7090						# score - numeric average
7091						# across all params
7092						# factors - arrayref of
7093						# human-readable
7094						# factor strings
7095						# per_parameter - hashref of per-
7096						# parameter score
7097						# and factor detail
7098						# Returns { level => 'none', ... } if
7099						# no parameters were found.
7100						#
7101						# Side effects: None.
7102						# --------------------------------------------------
7103						sub _calculate_input_confidence {
7104	101			101	5121	my ($self, $params) = @_;
7105
7106	101				126	my @factors; # Track all confidence factors
7107
7108	101	100			263	return { level => 'none', factors => ['No parameters found'] } unless keys %$params;
7109
7110	74				173	my $total_score = 0;
7111	74				77	my $count = 0;
7112	74				73	my %param_details; # Store per-parameter analysis
7113
7114	74				121	foreach my $param (keys %$params) {
7115	107				102	my $p = $params->{$param};
7116	107				95	my $score = 0;
7117	107				94	my @param_factors;
7118
7119						# Type information
7120	107	100			144	if ($p->{type}) {
7121	106	100 100	100		413	if ($p->{type} eq 'string' && ($p->{min} \|\| $p->{max} \|\| $p->{matches})) {
7122	9				12	$score += 25;
7123	9				13	push @param_factors, "Type: constrained string (+25)";
7124						} elsif ($p->{type} eq 'string') {
7125	23				26	$score += 10;
7126	23				33	push @param_factors, "Type: plain string (+10)";
7127						} else {
7128	74				74	$score += 30;
7129	74				118	push @param_factors, "Type: $p->{type} (+30)";
7130						}
7131						} else {
7132	1				2	push @param_factors, "No type information (-0)";
7133						}
7134
7135						# Constraints
7136	107	100			159	if (defined $p->{min}) {
7137	17				15	$score += 15;
7138	17				32	push @param_factors, 'Has min constraint (+15)';
7139						}
7140	107	100			157	if (defined $p->{max}) {
7141	14				17	$score += 15;
7142	14				22	push @param_factors, "Has max constraint (+15)";
7143						}
7144	107	100			152	if (defined $p->{optional}) {
7145	101				90	$score += 20;
7146	101				120	push @param_factors, "Optional/required explicitly defined (+20)";
7147						}
7148	107	100			150	if ($p->{matches}) {
7149	2				3	$score += 20;
7150	2				3	push @param_factors, 'Has regex pattern constraint (+20)';
7151						}
7152	107	100			145	if ($p->{isa}) {
7153	5				5	$score += 25;
7154	5				6	push @param_factors, "Specific class constraint: $p->{isa} (+25)";
7155						}
7156
7157						# Position information
7158	107	100			142	if (defined $p->{position}) {
7159	99				91	$score += 10;
7160	99				155	push @param_factors, "Position defined: $p->{position} (+10)";
7161						}
7162
7163						# Default value
7164	107	100			142	if (exists $p->{_default}) {
7165	23				16	$score += 10;
7166	23				25	push @param_factors, "Has default value (+10)";
7167						}
7168
7169						# Semantic information
7170	107	100			216	if ($p->{semantic}) {
7171	17				17	$score += 15;
7172	17				32	push @param_factors, "Semantic type: $p->{semantic} (+15)";
7173						}
7174
7175	107				191	$param_details{$param} = {
7176						score => $score,
7177						factors => \@param_factors
7178						};
7179
7180	107				100	$total_score += $score;
7181	107				117	$count++;
7182						}
7183
7184	74	50			149	my $avg = $count ? ($total_score / $count) : 0;
7185
7186						# Build summary factors
7187	74	100			243	push @factors, sprintf("Analyzed %d parameter%s", $count, $count == 1 ? '' : 's');
7188	74				646	push @factors, sprintf("Average confidence score: %.1f", $avg);
7189
7190						# Add top contributing factors
7191	74 42				175 83	my @sorted_params = sort { $param_details{$b}{score} <=> $param_details{$a}{score} } keys %param_details;
7192
7193	74	50			119	if (@sorted_params) {
7194	74				80	my $highest = $sorted_params[0];
7195	74				109	my $highest_score = $param_details{$highest}{score};
7196	74				155	push @factors, sprintf("Highest scoring parameter: \$$highest (score: %d)", $highest_score);
7197
7198	74	100			134	if (@sorted_params > 1) {
7199	23				23	my $lowest = $sorted_params[-1];
7200	23				30	my $lowest_score = $param_details{$lowest}{score};
7201	23				38	push @factors, sprintf("Lowest scoring parameter: \$$lowest (score: %d)", $lowest_score);
7202						}
7203						}
7204
7205						# Determine confidence level
7206	74				141	my $level;
7207	74	100 100 100			157	if ($avg >= $CONFIDENCE_HIGH_THRESHOLD) {
7208	54				292	$level = $LEVEL_HIGH;
7209	54				149	push @factors, "High confidence: comprehensive type and constraint information";
7210						} elsif ($avg >= $CONFIDENCE_MEDIUM_THRESHOLD) {
7211	15				86	$level = $LEVEL_MEDIUM;
7212	15				45	push @factors, "Medium confidence: some type or constraint information present";
7213						} elsif ($avg >= $CONFIDENCE_LOW_THRESHOLD) {
7214	2				23	$level = $LEVEL_LOW;
7215	2				9	push @factors, "Low confidence: minimal type information";
7216						} else {
7217	3				25	$level = $LEVEL_VERY_LOW;
7218	3				9	push @factors, "Very low confidence: little to no type information";
7219						}
7220
7221						return {
7222	74				290	level => $level,
7223						score => $avg,
7224						factors => \@factors,
7225						per_parameter => \%param_details
7226						};
7227						}
7228
7229						# --------------------------------------------------
7230						# _calculate_output_confidence
7231						#
7232						# Purpose: Calculate a confidence score and level
7233						# for the output analysis based on how
7234						# much return type, value, class,
7235						# context, and error convention
7236						# information was determined.
7237						#
7238						# Entry: $output - the output hashref as built
7239						# by _analyze_output.
7240						#
7241						# Exit: Returns a hashref with keys:
7242						# level - one of: none, very_low,
7243						# low, medium, high
7244						# score - numeric confidence score
7245						# factors - arrayref of factor strings
7246						# Returns { level => 'none', ... } if
7247						# output is empty.
7248						#
7249						# Side effects: None.
7250						# --------------------------------------------------
7251						sub _calculate_output_confidence {
7252	345			345	3963	my ($self, $output) = @_;
7253
7254	345				321	my @factors;
7255
7256	345	100			570	return { level => 'none', factors => ['No return information found'] } unless keys %$output;
7257
7258	327				359	my $score = 0;
7259
7260						# Type information
7261	327	100			551	if ($output->{type}) {
7262	319				365	$score += 30;
7263	319				610	push @factors, "Return type defined: $output->{type} (+30)";
7264						} else {
7265	8				17	push @factors, 'No return type information (-0)';
7266						}
7267
7268						# Specific value known
7269	327	100			599	if (defined $output->{value}) {
7270	28				49	$score += 30;
7271	28				58	push @factors, "Specific return value: $output->{value} (+30)";
7272						}
7273
7274						# Class information for objects
7275	327	100			493	if ($output->{isa}) {
7276	32				40	$score += 30;
7277	32				64	push @factors, "Returns specific class: $output->{isa} (+30)";
7278						}
7279
7280						# Context-aware returns
7281	327	100			525	if ($output->{_context_aware}) {
7282	4				4	$score += 20;
7283	4				6	push @factors, "Context-aware return (wantarray) (+20)";
7284
7285	4	50			11	if ($output->{_list_context}) {
7286	4				8	push @factors, " List context: $output->{_list_context}{type}";
7287						}
7288	4	100			5	if ($output->{_scalar_context}) {
7289	3				7	push @factors, " Scalar context: $output->{_scalar_context}{type}";
7290						}
7291						}
7292
7293						# Error handling information
7294	327	100			498	if ($output->{_error_return}) {
7295	17				19	$score += 15;
7296	17				36	push @factors, "Error return convention documented: $output->{_error_return} (+15)";
7297						}
7298
7299						# Success/failure pattern
7300	327	100			501	if ($output->{_success_failure_pattern}) {
7301	5				7	$score += 10;
7302	5				6	push @factors, 'Success/failure pattern detected (+10)';
7303						}
7304
7305						# Chainable methods
7306	327	100			525	if ($output->{_returns_self}) {
7307	7				7	$score += 15;
7308	7				10	push @factors, "Chainable method (fluent interface) (+15)";
7309						}
7310
7311						# Void context
7312	327	100			561	if ($output->{_void_context}) {
7313	5				6	$score += 20;
7314	5				8	push @factors, "Void context method (no meaningful return) (+20)";
7315						}
7316
7317						# Exception handling
7318	327	100	100		553	if ($output->{_error_handling} && $output->{_error_handling}{exception_handling}) {
7319	2				3	$score += 10;
7320	2				3	push @factors, 'Exception handling present (+10)';
7321						}
7322
7323	327				942	push @factors, sprintf("Total output confidence score: %d", $score);
7324
7325						# Determine confidence level
7326	327				310	my $level;
7327	327	100 100 100			1232	if ($score >= $CONFIDENCE_HIGH_THRESHOLD) {
7328	62				263	$level = $LEVEL_HIGH;
7329	62				195	push @factors, "High confidence: detailed return type and behavior";
7330						} elsif ($score >= $CONFIDENCE_MEDIUM_THRESHOLD) {
7331	19				141	$level = $LEVEL_MEDIUM;
7332	19				64	push @factors, "Medium confidence: return type defined";
7333						} elsif ($score >= $CONFIDENCE_LOW_THRESHOLD) {
7334	243				2128	$level = $LEVEL_LOW;
7335	243				690	push @factors, "Low confidence: minimal return information";
7336						} else {
7337	3				28	$level = $LEVEL_VERY_LOW;
7338	3				12	push @factors, 'Very low confidence: little return information';
7339						}
7340
7341						return {
7342	327				1272	level => $level,
7343						score => $score,
7344						factors => \@factors
7345						};
7346						}
7347
7348						# --------------------------------------------------
7349						# _generate_confidence_report
7350						#
7351						# Purpose: Generate a human-readable text report
7352						# of all confidence factors for a
7353						# schema, for debugging and review
7354						# purposes.
7355						#
7356						# Entry: $schema - schema hashref containing
7357						# a populated _analysis key.
7358						#
7359						# Exit: Returns a multi-line string report,
7360						# or nothing if $schema->{_analysis}
7361						# is absent.
7362						#
7363						# Side effects: None.
7364						# --------------------------------------------------
7365						sub _generate_confidence_report
7366						{
7367	3			3	19	my ($self, $schema) = @_;
7368
7369	3	100			6	return unless $schema->{_analysis};
7370
7371	2				4	my $analysis = $schema->{_analysis};
7372	2				2	my @report;
7373
7374	2		50		8	push @report, "Confidence Analysis for " . ($schema->{method_name} \|\| 'method');
7375	2				3	push @report, '=' x 60;
7376	2				2	push @report, '';
7377
7378	2				4	push @report, "Overall Confidence: " . uc($analysis->{overall_confidence});
7379	2				3	push @report, '';
7380
7381	2	50			4	if ($analysis->{confidence_factors}{input}) {
7382						push @report, (
7383						"Input Parameters:",
7384						" Confidence Level: " . uc($analysis->{input_confidence})
7385	2				5	);
7386	2 2				2 3	foreach my $factor (@{$analysis->{confidence_factors}{input}}) {
7387	2				4	push @report, " - $factor";
7388						}
7389	2				3	push @report, '';
7390						}
7391
7392	2	50			3	if ($analysis->{confidence_factors}{output}) {
7393						push @report, 'Return Value:',
7394	2				4	" Confidence Level: " . uc($analysis->{output_confidence});
7395	2 2				3 4	foreach my $factor (@{$analysis->{confidence_factors}{output}}) {
7396	2				2	push @report, " - $factor";
7397						}
7398	2				3	push @report, '';
7399						}
7400
7401	2	50			5	if ($analysis->{per_parameter_scores}) {
7402	0				0	push @report, 'Per-Parameter Analysis:';
7403	0 0				0 0	foreach my $param (sort keys %{$analysis->{per_parameter_scores}}) {
7404	0				0	my $details = $analysis->{per_parameter_scores}{$param};
7405	0				0	push @report, " \$$param (score: $details->{score}):";
7406	0 0				0 0	foreach my $factor (@{$details->{factors}}) {
7407	0				0	push @report, " - $factor";
7408						}
7409						}
7410	0				0	push @report, '';
7411						}
7412
7413	2				5	return join("\n", @report);
7414						}
7415
7416						# --------------------------------------------------
7417						# _generate_notes
7418						#
7419						# Purpose: Generate human-readable advisory notes
7420						# about parameters whose type or
7421						# optionality could not be determined,
7422						# to guide manual schema review.
7423						#
7424						# Entry: $params - hashref of merged parameter
7425						# specs.
7426						#
7427						# Exit: Returns an arrayref of note strings.
7428						# Returns an empty arrayref if all
7429						# parameters have known types and
7430						# optionality.
7431						#
7432						# Side effects: None.
7433						# --------------------------------------------------
7434						sub _generate_notes {
7435	333			333	1516	my ($self, $params) = @_;
7436
7437	333				329	my @notes;
7438
7439	333				670	foreach my $param (keys %$params) {
7440	230				264	my $p = $params->{$param};
7441
7442	230	100			384	unless ($p->{type}) {
7443	64				96	push @notes, "$param: type unknown - please review - will set to 'string' as a default";
7444						}
7445
7446	230	100			404	unless (defined $p->{optional}) {
7447	11				22	push @notes, "$param: optional status unknown";
7448						# Don't automatically set - let it be undef if we don't know
7449						}
7450						}
7451
7452	333				615	return \@notes;
7453						}
7454
7455						# --------------------------------------------------
7456						# _set_defaults
7457						#
7458						# Purpose: Apply default type values to any
7459						# parameters in a schema mode (input
7460						# or output) whose type was not set
7461						# during analysis, setting them to
7462						# 'string' as a conservative fallback.
7463						#
7464						# Entry: $schema - the schema hashref being
7465						# built by _analyze_method.
7466						# $mode - either 'input' or 'output'.
7467						#
7468						# Exit: Returns nothing. Modifies $schema in
7469						# place by setting type => 'string' on
7470						# any parameter that lacks a type, and
7471						# downgrading input confidence to 'low'.
7472						#
7473						# Side effects: Logs type defaulting to stdout when
7474						# verbose is set.
7475						#
7476						# Notes: Called after all analysis is complete
7477						# so that genuine type unknowns can be
7478						# distinguished from analysis gaps.
7479						# --------------------------------------------------
7480						sub _set_defaults {
7481	658			658	737	my ($self, $schema, $mode) = @_;
7482
7483	658				573	my $params = $schema->{$mode};
7484
7485	658				830	foreach my $param (keys %$params) {
7486	832				755	my $p = $params->{$param};
7487
7488	832	100			1091	next unless(ref($p) eq 'HASH');
7489	252	100			424	unless ($p->{type}) {
7490	81				159	$self->_log(" DEBUG {$mode}{$param}: Setting to 'string' as a default");
7491	81				184	$p->{'type'} = 'string';
7492	81				137	$schema->{_confidence}{$mode}->{level} = 'low'; # Setting a default means it's a guess
7493						}
7494						}
7495						}
7496
7497						# --------------------------------------------------
7498						# _analyze_relationships
7499						#
7500						# Purpose: Detect inter-parameter relationships
7501						# in a method's source code, including
7502						# mutually exclusive parameters, required
7503						# groups, conditional requirements,
7504						# dependencies, and value-based
7505						# constraints.
7506						#
7507						# Entry: $method - method hashref containing
7508						# at minimum a 'body' key
7509						# with the source string.
7510						#
7511						# Exit: Returns an arrayref of relationship
7512						# hashrefs. Returns an empty arrayref
7513						# if no parameters or no relationships
7514						# are found.
7515						#
7516						# Side effects: Logs detections to stdout when
7517						# verbose is set.
7518						#
7519						# Notes: Parameter names are extracted via
7520						# _extract_parameters_from_signature, so
7521						# every style it supports -- my (...) =
7522						# @_, shift-style (my $x = shift), direct-
7523						# index ($_[N]), and modern signatures --
7524						# is analysed for relationships, not just
7525						# the my (...) = @_ list-assignment form.
7526						# --------------------------------------------------
7527						sub _analyze_relationships {
7528	334			334	443	my ($self, $method) = @_;
7529
7530	334				363	my $code = $method->{body};
7531	334				340	my @relationships;
7532
7533						# Extract all parameter names from the method, using the same
7534						# multi-style detection used for schema population so shift-style
7535						# and modern-signature methods get relationship analysis too
7536						my %params;
7537	334				822	$self->_extract_parameters_from_signature(\%params, $code);
7538	334 95				685 191	my @param_names = sort { $params{$a}{position} <=> $params{$b}{position} } keys %params;
7539
7540	334	100			563	return [] unless @param_names;
7541
7542						# Detect mutually exclusive parameters
7543	154 154				185 431	push @relationships, @{$self->_detect_mutually_exclusive($code, \@param_names)};
7544
7545						# Detect required groups (OR logic)
7546	154 154				214 414	push @relationships, @{$self->_detect_required_groups($code, \@param_names)};
7547
7548						# Detect conditional requirements (IF-THEN)
7549	154 154				190 419	push @relationships, @{$self->_detect_conditional_requirements($code, \@param_names)};
7550
7551						# Detect dependencies
7552	154 154				172 396	push @relationships, @{$self->_detect_dependencies($code, \@param_names)};
7553
7554						# Detect value-based constraints
7555	154 154				207 400	push @relationships, @{$self->_detect_value_constraints($code, \@param_names)};
7556
7557						# Deduplicate relationships
7558	154				392	my @unique = $self->_deduplicate_relationships(\@relationships);
7559
7560	154				405	return \@unique;
7561						}
7562
7563						# --------------------------------------------------
7564						# _deduplicate_relationships
7565						#
7566						# Purpose: Remove duplicate relationship entries
7567						# from the relationships list by
7568						# computing a canonical signature for
7569						# each relationship type.
7570						#
7571						# Entry: $relationships - arrayref of
7572						# relationship hashrefs.
7573						#
7574						# Exit: Returns a deduplicated list of
7575						# relationship hashrefs.
7576						#
7577						# Side effects: None.
7578						# --------------------------------------------------
7579						sub _deduplicate_relationships {
7580	158			158	1097	my ($self, $relationships) = @_;
7581
7582	158				179	my @unique;
7583						my %seen;
7584
7585	158				242	foreach my $rel (@$relationships) {
7586						# Create a signature for this relationship
7587	31				28	my $sig;
7588	31	100 100 100 100 100 50			70	if ($rel->{type} eq 'mutually_exclusive') {
7589	13 13				14 34	$sig = join(':', 'mutex', sort @{$rel->{params}});
7590						} elsif ($rel->{type} eq 'required_group') {
7591	5 5				7 13	$sig = join(':', 'reqgroup', sort @{$rel->{params}});
7592						} elsif ($rel->{type} eq 'conditional_requirement') {
7593	7				10	$sig = join(':', 'condreq', $rel->{if}, $rel->{then_required});
7594						} elsif ($rel->{type} eq 'dependency') {
7595	3				6	$sig = join(':', 'dep', $rel->{param}, $rel->{requires});
7596						} elsif ($rel->{type} eq 'value_constraint') {
7597	2				6	$sig = join(':', 'valcon', $rel->{if}, $rel->{then}, $rel->{operator}, $rel->{value});
7598						} elsif ($rel->{type} eq 'value_conditional') {
7599	1				3	$sig = join(':', 'valcond', $rel->{if}, $rel->{equals}, $rel->{then_required});
7600						} else {
7601	0				0	$sig = join(':', $rel->{type}, %$rel);
7602						}
7603
7604	31	100			57	unless ($seen{$sig}++) {
7605	25				23	push @unique, $rel;
7606						}
7607						}
7608
7609	158				241	return @unique;
7610						}
7611
7612						# --------------------------------------------------
7613						# _detect_mutually_exclusive
7614						#
7615						# Purpose: Detect pairs of parameters that cannot
7616						# be specified together, by searching
7617						# for die/croak/confess patterns
7618						# that fire when both are truthy.
7619						#
7620						# Entry: $code - method body source string.
7621						# $param_names - arrayref of parameter
7622						# name strings.
7623						#
7624						# Exit: Returns an arrayref of relationship
7625						# hashrefs of type 'mutually_exclusive'.
7626						# Returns an empty arrayref if none found.
7627						#
7628						# Side effects: Logs detections to stdout when
7629						# verbose is set.
7630						# --------------------------------------------------
7631						sub _detect_mutually_exclusive {
7632	159			159	1498	my ($self, $code, $param_names) = @_;
7633
7634	159				171	my @relationships;
7635
7636						# Pattern 1: die/croak if $x && $y
7637						# Look for: die/croak ... if $param1 && $param2
7638	159				240	foreach my $param1 (@$param_names) {
7639	236				267	foreach my $param2 (@$param_names) {
7640	466	100			575	next if $param1 eq $param2;
7641
7642						# Check various patterns
7643	230	100	100		11350	if ($code =~ /(?:die\|croak\|confess)[^;]*if\s+\$$param1\s+&&\s+\$$param2/ \|\|
7644						$code =~ /(?:die\|croak\|confess)[^;]*if\s+\$$param2\s+&&\s+\$$param1/) {
7645
7646						# Avoid duplicates (param1,param2 vs param2,param1)
7647	22				23	my $found_reverse = 0;
7648	22				26	foreach my $rel (@relationships) {
7649	13	100	33 67		50	if ($rel->{type} eq 'mutually_exclusive' &&
7650						(($rel->{params}[0] eq $param2 && $rel->{params}[1] eq $param1))) {
7651	11				44	$found_reverse = 1;
7652	11				10	last;
7653						}
7654						}
7655
7656	22	100			44	next if $found_reverse;
7657
7658	11				39	push @relationships, {
7659						type => 'mutually_exclusive',
7660						params => [$param1, $param2],
7661						description => "Cannot specify both $param1 and $param2"
7662						};
7663
7664	11				33	$self->_log(" RELATIONSHIP: $param1 and $param2 are mutually exclusive");
7665						}
7666
7667						# Pattern 2: die "Cannot specify both X and Y"
7668	219	100	67		22350	if ($code =~ /(?:die\|croak\|confess)\s+['"](Cannot\|Can't)[^'"]both[^'"]$param1[^'"]*$param2/i \|\|
7669						$code =~ /(?:die\|croak\|confess)\s+['"](Cannot\|Can't)[^'"]both[^'"]$param2[^'"]*$param1/i) {
7670
7671	1				1	my $found_reverse = 0;
7672	1				2	foreach my $rel (@relationships) {
7673	1	50	33 33		7	if ($rel->{type} eq 'mutually_exclusive' &&
7674						(($rel->{params}[0] eq $param2 && $rel->{params}[1] eq $param1))) {
7675	0				0	$found_reverse = 1;
7676	0				0	last;
7677						}
7678						}
7679
7680	1	50			1	next if $found_reverse;
7681
7682	1				3	push @relationships, {
7683						type => 'mutually_exclusive',
7684						params => [$param1, $param2],
7685						description => "Cannot specify both $param1 and $param2"
7686						};
7687
7688	1				2	$self->_log(" RELATIONSHIP: $param1 and $param2 are mutually exclusive (from error message)");
7689						}
7690						}
7691						}
7692
7693	159				275	return \@relationships;
7694						}
7695
7696						# --------------------------------------------------
7697						# _detect_required_groups
7698						#
7699						# Purpose: Detect parameter groups where at least
7700						# one parameter must be specified (OR
7701						# logic), by searching for die/croak
7702						# patterns that fire unless any of the
7703						# group is truthy.
7704						#
7705						# Entry: $code - method body source string.
7706						# $param_names - arrayref of parameter
7707						# name strings.
7708						#
7709						# Exit: Returns an arrayref of relationship
7710						# hashrefs of type 'required_group'.
7711						# Returns an empty arrayref if none found.
7712						#
7713						# Side effects: Logs detections to stdout when
7714						# verbose is set.
7715						# --------------------------------------------------
7716						sub _detect_required_groups {
7717	157			157	1141	my ($self, $code, $param_names) = @_;
7718
7719	157				192	my @relationships;
7720
7721						# Pattern 1: die/croak unless $x \|\| $y
7722	157				218	foreach my $param1 (@$param_names) {
7723	232				268	foreach my $param2 (@$param_names) {
7724	458	100			520	next if $param1 eq $param2;
7725
7726	226	100	100		8978	if ($code =~ /(?:die\|croak\|confess)[^;]*unless\s+\$$param1\s+\\|\\|\s+\$$param2/ \|\|
7727						$code =~ /(?:die\|croak\|confess)[^;]*unless\s+\$$param2\s+\\|\\|\s+\$$param1/) {
7728
7729						# Avoid duplicates
7730	10				11	my $found_reverse = 0;
7731	10				12	foreach my $rel (@relationships) {
7732	5	50	33 33		30	if ($rel->{type} eq 'required_group' &&
7733						(($rel->{params}[0] eq $param2 && $rel->{params}[1] eq $param1))) {
7734	5				7	$found_reverse = 1;
7735	5				6	last;
7736						}
7737						}
7738
7739	10	100			16	next if $found_reverse;
7740
7741	5				22	push @relationships, {
7742						type => 'required_group',
7743						params => [$param1, $param2],
7744						logic => 'or',
7745						description => "Must specify either $param1 or $param2"
7746						};
7747
7748	5				18	$self->_log(" RELATIONSHIP: Must specify either $param1 or $param2");
7749						}
7750
7751						# Pattern 2: die "Must specify either X or Y"
7752	221	100	67		21909	if ($code =~ /(?:die\|croak\|confess)\s+['"]Must\s+specify\s+either[^'"]$param1[^'"]or[^'"]*$param2/i \|\|
7753						$code =~ /(?:die\|croak\|confess)\s+['"]Must\s+specify\s+either[^'"]$param2[^'"]or[^'"]*$param1/i) {
7754
7755	1				1	my $found_reverse = 0;
7756	1				2	foreach my $rel (@relationships) {
7757	1	50	33 33		5	if ($rel->{type} eq 'required_group' &&
7758						(($rel->{params}[0] eq $param2 && $rel->{params}[1] eq $param1))) {
7759	0				0	$found_reverse = 1;
7760	0				0	last;
7761						}
7762						}
7763
7764	1	50			4	next if $found_reverse;
7765
7766	1				3	push @relationships, {
7767						type => 'required_group',
7768						params => [$param1, $param2],
7769						logic => 'or',
7770						description => "Must specify either $param1 or $param2"
7771						};
7772
7773	1				3	$self->_log(" RELATIONSHIP: Must specify either $param1 or $param2 (from error message)");
7774						}
7775						}
7776						}
7777
7778	157				200	return \@relationships;
7779						}
7780
7781						# --------------------------------------------------
7782						# _detect_conditional_requirements
7783						#
7784						# Purpose: Detect IF-THEN parameter relationships
7785						# where one parameter being present
7786						# makes another required, by searching
7787						# for die/croak patterns of the form
7788						# 'die if $x && !$y'.
7789						#
7790						# Entry: $code - method body source string.
7791						# $param_names - arrayref of parameter
7792						# name strings.
7793						#
7794						# Exit: Returns an arrayref of relationship
7795						# hashrefs of type
7796						# 'conditional_requirement'.
7797						# Returns an empty arrayref if none found.
7798						#
7799						# Side effects: Logs detections to stdout when
7800						# verbose is set.
7801						# --------------------------------------------------
7802						sub _detect_conditional_requirements {
7803	157			157	1382	my ($self, $code, $param_names) = @_;
7804
7805	157				148	my @relationships;
7806
7807	157				219	foreach my $param1 (@$param_names) {
7808	232				250	foreach my $param2 (@$param_names) {
7809	458	100			508	next if $param1 eq $param2;
7810
7811						# Pattern 1: die if $x && !$y (if x then y required)
7812	226	100			4516	if ($code =~ /(?:die\|croak\|confess)[^;]*if\s+\$$param1\s+&&\s+!\$$param2/) {
7813	5				23	push @relationships, {
7814						type => 'conditional_requirement',
7815						if => $param1,
7816						then_required => $param2,
7817						description => "When $param1 is specified, $param2 is required"
7818						};
7819
7820	5				14	$self->_log(" RELATIONSHIP: $param1 requires $param2");
7821						}
7822
7823						# Pattern 2: die if $x && !defined($y)
7824	226	50			6605	if ($code =~ /(?:die\|croak\|confess)[^;]if\s+\$$param1\s+&&\s+!defined\s$\s\$$param2\s$/) {
7825	0				0	push @relationships, {
7826						type => 'conditional_requirement',
7827						if => $param1,
7828						then_required => $param2,
7829						description => "When $param1 is specified, $param2 is required"
7830						};
7831
7832	0				0	$self->_log(" RELATIONSHIP: $param1 requires $param2 (defined check)");
7833						}
7834
7835						# Pattern 3: Error message "X requires Y"
7836	226	100			11160	if ($code =~ /(?:die\|croak\|confess)\s+['"]\w$param1[^'"]requires[^'"]*$param2/i) {
7837	4				13	push @relationships, {
7838						type => 'conditional_requirement',
7839						if => $param1,
7840						then_required => $param2,
7841						description => "When $param1 is specified, $param2 is required"
7842						};
7843
7844	4				10	$self->_log(" RELATIONSHIP: $param1 requires $param2 (from error message)");
7845						}
7846						}
7847						}
7848
7849	157				195	return \@relationships;
7850						}
7851
7852						# --------------------------------------------------
7853						# _detect_dependencies
7854						#
7855						# Purpose: Detect simple parameter dependencies
7856						# where one parameter requires another
7857						# to also be present, by combining
7858						# error message pattern matching with
7859						# code condition matching.
7860						#
7861						# Entry: $code - method body source string.
7862						# $param_names - arrayref of parameter
7863						# name strings.
7864						#
7865						# Exit: Returns an arrayref of relationship
7866						# hashrefs of type 'dependency'.
7867						# Returns an empty arrayref if none found.
7868						#
7869						# Side effects: Logs detections to stdout when
7870						# verbose is set.
7871						# --------------------------------------------------
7872						sub _detect_dependencies {
7873	158			158	33602	my ($self, $code, $param_names) = @_;
7874
7875	158				160	my @relationships;
7876
7877	158				200	foreach my $param1 (@$param_names) {
7878	234				237	foreach my $param2 (@$param_names) {
7879	462	100			524	next if $param1 eq $param2;
7880
7881						# Pattern 1: Error message mentions "X requires Y" AND code checks $x && !$y
7882						# Split into two checks to be more flexible
7883	228	100	100		10729	if (($code =~ /(?:die\|croak\|confess)\s+['"]\w$param1[^'"]requires[^'"]*$param2/i) &&
7884						($code =~ /if\s+\$$param1\s+&&\s+!\$$param2/)) {
7885
7886	6				26	push @relationships, {
7887						type => 'dependency',
7888						param => $param1,
7889						requires => $param2,
7890						description => "$param1 requires $param2 to be specified"
7891						};
7892
7893	6				17	$self->_log(" RELATIONSHIP: $param1 depends on $param2");
7894						}
7895						}
7896						}
7897
7898	158				217	return \@relationships;
7899						}
7900
7901						# --------------------------------------------------
7902						# _detect_value_constraints
7903						#
7904						# Purpose: Detect value-based constraints between
7905						# parameters, such as 'if $ssl then
7906						# $port must equal 443' or 'if $mode
7907						# eq secure then $key is required'.
7908						#
7909						# Entry: $code - method body source string.
7910						# $param_names - arrayref of parameter
7911						# name strings.
7912						#
7913						# Exit: Returns an arrayref of relationship
7914						# hashrefs of type 'value_constraint'
7915						# or 'value_conditional'.
7916						# Returns an empty arrayref if none found.
7917						#
7918						# Side effects: Logs detections to stdout when
7919						# verbose is set.
7920						# --------------------------------------------------
7921						sub _detect_value_constraints {
7922	155			155	229	my ($self, $code, $param_names) = @_;
7923
7924	155				205	my @relationships;
7925
7926	155				201	foreach my $param1 (@$param_names) {
7927	228				242	foreach my $param2 (@$param_names) {
7928	450	100			473	next if $param1 eq $param2;
7929
7930						# Pattern 1: die if $x && $y != value
7931	222	100			6178	if ($code =~ /(?:die\|croak\|confess)[^;]if\s+\$$param1\s+&&\s+\$$param2\s!=\s*(\d+)/) {
7932	3				6	my $value = $1;
7933	3				15	push @relationships, {
7934						type => 'value_constraint',
7935						if => $param1,
7936						then => $param2,
7937						operator => '==',
7938						value => $value,
7939						description => "When $param1 is specified, $param2 must equal $value"
7940						};
7941
7942	3				9	$self->_log(" RELATIONSHIP: $param1 requires $param2 == $value");
7943						}
7944
7945						# Pattern 2: die if $x && $y < value
7946	222	50			6009	if ($code =~ /(?:die\|croak\|confess)[^;]if\s+\$$param1\s+&&\s+\$$param2\s<\s*(\d+)/) {
7947	0				0	my $value = $1;
7948	0				0	push @relationships, {
7949						type => 'value_constraint',
7950						if => $param1,
7951						then => $param2,
7952						operator => '>=',
7953						value => $value,
7954						description => "When $param1 is specified, $param2 must be >= $value"
7955						};
7956
7957	0				0	$self->_log(" RELATIONSHIP: $param1 requires $param2 >= $value");
7958						}
7959
7960						# Pattern 3: die if $x eq 'value' && !$y
7961	222	100			7751	if ($code =~ /(?:die\|croak\|confess)[^;]*if\s+\$$param1\s+eq\s+['"]([^'"]+)['"]\s+&&\s+!\$$param2/) {
7962	1				2	my $value = $1;
7963	1				5	push @relationships, {
7964						type => 'value_conditional',
7965						if => $param1,
7966						equals => $value,
7967						then_required => $param2,
7968						description => "When $param1 equals '$value', $param2 is required"
7969						};
7970
7971	1				4	$self->_log(" RELATIONSHIP: $param1='$value' requires $param2");
7972						}
7973						}
7974						}
7975
7976	155				203	return \@relationships;
7977						}
7978
7979						# Write a single method schema to a YAML file in output_dir.
7980						#
7981						# Entry: $method_name is a non-empty string; $schema is a hashref.
7982						# Exit: YAML file written to output_dir/$method_name.yml.
7983						# Side effects: Creates output_dir if it does not exist.
7984						# Notes: Croaks if output_dir was not set in new().
7985
7986						sub _write_schema {
7987	123			123	3442	my ($self, $method_name, $schema) = @_;
7988
7989						# output_dir is required here â€” croak early with a clear message
7990						# rather than letting make_path fail with a cryptic error
7991	123	100			292	croak(__PACKAGE__, ': output_dir must be provided to new() when writing schema files') unless defined $self->{output_dir};
7992
7993	122	100			3101	make_path($self->{output_dir}) unless -d $self->{output_dir};
7994
7995	122				231	my $filename = "$self->{output_dir}/${method_name}.yml";
7996
7997						# Configure YAML::XS to not quote numeric strings
7998	122				192	local $YAML::XS::QuoteNumericStrings = 0;
7999
8000						# Extract package name for module field
8001	122				172	my $package_name = '';
8002	122	100			349	if ($self->{_document}) {
8003	121				310	my $package_stmt = $self->{_document}->find_first('PPI::Statement::Package');
8004	121	100			21260	$package_name = $package_stmt ? $package_stmt->namespace : '';
8005	121		33		1946	$self->{_package_name} //= $package_name;
8006						}
8007
8008						# Clean up schema for output - use the format expected by App::Test::Generator::Template
8009	122				747	my $output = {
8010						function => $method_name,
8011						module => $package_name,
8012						config => {
8013						close_stdin => 1,
8014						dedup => 1,
8015						test_nuls => 0,
8016						test_undef => 0,
8017						test_empty => 1,
8018						test_non_ascii => 0,
8019						test_security => 0
8020						}
8021						};
8022
8023						# Process input parameters with advanced type handling
8024	122	100			235	if($schema->{'input'}) {
8025	119 119	100			112 203	if(scalar(keys %{$schema->{'input'}})) {
8026	97				137	$output->{'input'} = {};
8027
8028	97 97				106 197	foreach my $param_name (keys %{$schema->{'input'}}) {
8029	162				183	my $param = $schema->{'input'}{$param_name};
8030	162	100			214	if($param->{name}) {
8031	24				20	my $name = delete $param->{name};
8032	24	50			31	if($name ne $param_name) {
8033						# Sanity check
8034	0				0	croak("BUG: Parameter name - expected $param_name, got $name");
8035						}
8036						}
8037	162				322	my $cleaned_param = $self->_serialize_parameter_for_yaml($param);
8038	162				208	$output->{'input'}{$param_name} = $cleaned_param;
8039						}
8040
8041						# If some params have positions and others don't, treat the whole
8042						# input as a named (hash) API and strip all positions. Mixed
8043						# position state arises when a named-API method also happens to
8044						# have a Params::Get positional-key call alongside =head4 Input
8045						# named-block params that carry no position.
8046	97 162 97				122 260 156	my @with_pos = grep { defined $output->{input}{$_}{position} } keys %{$output->{input}};
8047	97 162 97				122 219 142	my @without_pos = grep { !defined $output->{input}{$_}{position} } keys %{$output->{input}};
8048	97	50	67		289	if (@with_pos && @without_pos) {
8049	0				0	delete $output->{input}{$_}{position} for @with_pos;
8050						}
8051						} else {
8052	22				31	delete $output->{input};
8053						}
8054						}
8055
8056						# Process output
8057	122 122	50	50		278 243	if($schema->{'output'} && (scalar(keys %{$schema->{'output'}}))) {
8058	122 121	100	100		317 257	if((ref($schema->{output}{_error_handling}) eq 'HASH') && (scalar(keys %{$schema->{output}{_error_handling}}) == 0)) {
8059	108				138	delete $schema->{output}{_error_handling};
8060						}
8061	122				191	$output->{'output'} = $schema->{'output'};
8062						}
8063
8064	122	50	67		387	if($schema->{'output'}{'type'} && ($schema->{'output'}{'type'} eq 'scalar')) {
8065	0				0	$schema->{'output'}{'type'} = 'string';
8066	0				0	$schema->{_confidence}{output}->{level} = 'low'; # A guess
8067						}
8068
8069						# Add 'new' field if object instantiation is needed
8070	122	100			176	if ($schema->{new}) {
8071						# TODO: consider allowing parent class packages up the ISA chain
8072	87	100	67		268	if(ref($schema->{new}) \|\| ($schema->{new} eq $package_name)) {
8073	86	50			210	$output->{new} = $schema->{new} eq $package_name ? undef : $schema->{'new'};
8074						} else {
8075	1				3	$self->_log(" NEW: Don't use $schema->{new} for object insantiation");
8076	1				1	delete $schema->{new};
8077	1				1	delete $output->{new};
8078						}
8079						}
8080
8081	122	100			243	if(!defined($schema->{_confidence}{input}->{level})) {
8082	89				254	$schema->{_confidence}{input} = $self->_calculate_input_confidence($schema->{input});
8083						}
8084	122	100			239	if(!defined($schema->{_confidence}{output}->{level})) {
8085	1				5	$schema->{_confidence}{output} = $self->_calculate_output_confidence($schema->{output});
8086						}
8087
8088						# Add relationships if detected
8089	122 7	100	67		237 11	if ($schema->{relationships} && @{$schema->{relationships}}) {
8090	7				7	$output->{relationships} = $schema->{relationships};
8091						}
8092
8093	122 7	50	100		233 17	if($schema->{accessor} && scalar(keys %{$schema->{accessor}})) {
8094	7				12	$output->{accessor} = $schema->{accessor};
8095						}
8096
8097	122				451	open my $fh, '>', $filename;
8098	122				43499	print $fh YAML::XS::Dump($output);
8099	122				690	print $fh $self->_generate_schema_comments($schema, $method_name);
8100	122				292	close $fh;
8101
8102						my $rel_info = $schema->{relationships} ?
8103	122 7	100			16149 40	' [' . scalar(@{$schema->{relationships}}) . ' relationships]' : '';
8104						$self->_log(" Wrote: $filename (input confidence: $schema->{_confidence}{input}->{level})" .
8105	122	100			560	($schema->{new} ? " [requires: $schema->{new}]" : '') . $rel_info);
8106						}
8107
8108						# --------------------------------------------------
8109						# _generate_schema_comments
8110						#
8111						# Purpose: Generate the YAML comment block
8112						# appended to the end of each written
8113						# schema file, containing provenance,
8114						# confidence levels, parameter type
8115						# notes, relationship summaries, and
8116						# warnings about types requiring
8117						# special test setup.
8118						#
8119						# Entry: $schema - the schema hashref as
8120						# built by _analyze_method.
8121						# $method_name - the method name string,
8122						# used in the fuzz
8123						# command hint.
8124						#
8125						# Exit: Returns a string of YAML comment lines
8126						# beginning with a blank line and ending
8127						# with a trailing newline.
8128						#
8129						# Side effects: None.
8130						# --------------------------------------------------
8131						sub _generate_schema_comments {
8132	127			127	274	my ($self, $schema, $method_name) = @_;
8133
8134	127				142	my @comments;
8135
8136	127				202	push @comments, '';
8137	127				237	push @comments, '# Generated by ' . ref($self);
8138	127				359	push @comments, "# Run: fuzz-harness-generator -r $self->{output_dir}/${method_name}.yml";
8139	127				154	push @comments, '#';
8140	127				239	push @comments, "# Input confidence: $schema->{_confidence}{input}->{level}";
8141	127				230	push @comments, "# Output confidence: $schema->{_confidence}{output}->{level}";
8142
8143						# Add notes about parameters
8144	127	100			270	if ($schema->{input}) {
8145	119				113	my @param_notes;
8146	119 119				126 325	foreach my $param_name (sort keys %{$schema->{input}}) {
8147	162				165	my $p = $schema->{input}{$param_name};
8148
8149	162	100			212	if ($p->{semantic}) {
8150	18				34	push @param_notes, "$param_name: $p->{semantic}";
8151						}
8152
8153	162	100			205	if ($p->{enum}) {
8154	5 5				10 6	push @param_notes, "$param_name: enum with " . scalar(@{$p->{enum}}) . " values";
8155						}
8156
8157	162	100			225	if ($p->{isa}) {
8158	6				12	push @param_notes, "$param_name: requires $p->{isa} object";
8159						}
8160						}
8161
8162	119	100			219	if (@param_notes) {
8163	20				21	push @comments, '#';
8164	20				21	push @comments, '# Parameter types detected:';
8165	20				20	foreach my $note (@param_notes) {
8166	29				41	push @comments, "# - $note";
8167						}
8168						}
8169						}
8170
8171						# Add relationship notes
8172	127 8	100	67		317 18	if ($schema->{relationships} && @{$schema->{relationships}}) {
8173	8				27	push @comments, (
8174						'#',
8175						'# Parameter relationships detected:'
8176						);
8177	8 8				8 14	foreach my $rel (@{$schema->{relationships}}) {
8178	17		33		26	my $desc = $rel->{description} \|\| _format_relationship($rel);
8179	17				23	push @comments, "# - $desc";
8180						}
8181						}
8182
8183						# Add general notes
8184	127 126	100	100		342 301	if ($schema->{_notes} && scalar(@{$schema->{_notes}})) {
8185	32				46	push @comments, '#';
8186	32				36	push @comments, '# Notes:';
8187	32 32				32 53	foreach my $note (@{$schema->{_notes}}) {
8188	50				72	push @comments, "# - $note";
8189						}
8190						}
8191
8192	127	100			243	if($schema->{_analysis}) {
8193	121				223	push @comments, (
8194						'#',
8195						'# Analysis:',
8196						'# TODO:',
8197						);
8198						# confidence_factors:
8199						# input:
8200						# - No parameters found
8201						# output:
8202						# - 'Return type defined: object (+30)'
8203						# - 'Total output confidence score: 30'
8204						# - 'Medium confidence: return type defined'
8205						# input_confidence: none
8206						# output_confidence: medium
8207						# overall_confidence: none
8208						}
8209
8210						# Add warnings for complex types
8211	127				126	my @warnings;
8212	127	100			249	if ($schema->{input}) {
8213	119 119				129 182	foreach my $param_name (keys %{$schema->{input}}) {
8214	162				143	my $p = $schema->{input}{$param_name};
8215
8216	162	100	67		362	if ($p->{type} && $p->{type} eq 'coderef') {
8217	3				6	push @warnings, "Parameter '$param_name' is a coderef - you'll need to provide a sub {} in tests";
8218						}
8219
8220	162	100	100		269	if ($p->{semantic} && $p->{semantic} eq 'filehandle') {
8221	2				4	push @warnings, "Parameter '$param_name' is a filehandle - consider using IO::String or mock";
8222						}
8223
8224	162	100	100		280	if ($p->{isa} && $p->{isa} =~ /DateTime/) {
8225	2				4	push @warnings, "Parameter '$param_name' requires DateTime - ensure DateTime is loaded";
8226						}
8227						}
8228						}
8229
8230	127	100			202	if (@warnings) {
8231	7				7	push @comments, '#';
8232	7				8	push @comments, '# WARNINGS - Manual test setup may be required:';
8233	7				10	foreach my $warning (@warnings) {
8234	7				9	push @comments, "# ! $warning";
8235						}
8236						}
8237
8238	127				234	push @comments, '';
8239
8240	127				361	return join("\n", @comments);
8241						}
8242
8243						# --------------------------------------------------
8244						# _serialize_parameter_for_yaml
8245						#
8246						# Purpose: Convert a parameter spec hashref into
8247						# a cleaned, YAML-serialisable form
8248						# suitable for App::Test::Generator
8249						# consumption, handling semantic type
8250						# mappings, enum values, and object
8251						# class annotations.
8252						#
8253						# Entry: $param - parameter spec hashref as
8254						# produced by the merge and
8255						# analysis pipeline.
8256						#
8257						# Exit: Returns a new hashref containing only
8258						# the fields App::Test::Generator
8259						# understands, with internal _ keys
8260						# and semantic keys removed or converted.
8261						#
8262						# Side effects: None.
8263						#
8264						# Notes: Semantic types are mapped to
8265						# appropriate base types with additional
8266						# constraint and note fields.
8267						# The original $param hashref is not
8268						# modified.
8269						# --------------------------------------------------
8270						sub _serialize_parameter_for_yaml {
8271	177			177	2996	my ($self, $param) = @_;
8272
8273	177				154	my %cleaned;
8274
8275						# Copy basic fields that App::Test::Generator expects
8276	177				220	foreach my $field (qw(type position optional min max matches default)) {
8277	1239	100			1378	$cleaned{$field} = $param->{$field} if defined $param->{$field};
8278						}
8279
8280						# Handle advanced type mappings
8281	177	100			251	if(my $semantic = $param->{semantic}) {
8282	25	100 50 100 100 100 50 100 100 100 100			166	if ($semantic eq 'datetime_object') {
8283						# DateTime objects: test generator needs to know how to create them
8284	2				3	$cleaned{type} = 'object';
8285	2		50		4	$cleaned{isa} = $param->{isa} \|\| 'DateTime';
8286	2				4	$cleaned{_note} = 'Requires DateTime object';
8287						} elsif ($semantic eq 'timepiece_object') {
8288	0				0	$cleaned{type} = 'object';
8289	0		0		0	$cleaned{isa} = $param->{isa} \|\| 'Time::Piece';
8290	0				0	$cleaned{_note} = 'Requires Time::Piece object';
8291						} elsif ($semantic eq 'date_string') {
8292						# Date strings: provide regex pattern
8293	1				2	$cleaned{type} = 'string';
8294	1		50		4	$cleaned{matches} \|\|= '/^\d{4}-\d{2}-\d{2}$/';
8295	1				2	$cleaned{_example} = '2024-12-12';
8296						} elsif ($semantic eq 'iso8601_string') {
8297	1				2	$cleaned{type} = 'string';
8298	1		50		3	$cleaned{matches} \|\|= '/^\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}Z?$/';
8299	1				1	$cleaned{_example} = '2024-12-12T10:30:00Z';
8300						} elsif ($semantic eq 'unix_timestamp') {
8301	3				7	$cleaned{type} = 'integer';
8302	3		50		10	$cleaned{min} \|\|= 0;
8303	3		67		10	$cleaned{max} \|\|= $INT32_MAX; # 32-bit max
8304	3				9	$cleaned{_note} = 'UNIX timestamp';
8305						} elsif ($semantic eq 'datetime_parseable') {
8306	0				0	$cleaned{type} = 'string';
8307	0				0	$cleaned{_note} = 'Must be parseable as datetime';
8308						} elsif ($semantic eq 'filehandle') {
8309						# File handles: special handling needed
8310	2				3	$cleaned{type} = 'object';
8311	2		50		5	$cleaned{isa} = $param->{isa} \|\| 'IO::Handle';
8312	2				4	$cleaned{_note} = 'File handle - may need mock in tests';
8313						} elsif ($semantic eq 'filepath') {
8314						# File paths: string with path pattern
8315	3				6	$cleaned{type} = 'string';
8316	3		50		11	$cleaned{matches} \|\|= '/^[\\w\\/.\\-_]+$/';
8317	3				6	$cleaned{_note} = 'File path';
8318						} elsif ($semantic eq 'callback') {
8319						# Coderefs: mark as special type
8320	5				10	$cleaned{type} = 'coderef';
8321	5				9	$cleaned{_note} = 'CODE reference - provide sub { } in tests';
8322						} elsif ($semantic eq 'enum') {
8323						# Enum: keep as string but add valid values
8324	5				9	$cleaned{type} = 'string';
8325	5	50	33		21	if ($param->{enum} && ref($param->{enum}) eq 'ARRAY') {
8326	5				8	$cleaned{enum} = $param->{enum};
8327	5 5				6 13	$cleaned{_note} = 'Must be one of: ' . join(', ', @{$param->{enum}});
8328						}
8329						}
8330						}
8331
8332						# Handle memberof even if not marked with semantic.
8333						# enum and memberof are mutually exclusive â€” only set memberof when enum
8334						# is not already being output (avoids the "has both" validation error).
8335	177	100	75		317	if($param->{enum} && ref($param->{enum}) eq 'ARRAY' && !$cleaned{enum}) {
8336	2				4	$cleaned{memberof} = $param->{enum};
8337						}
8338	177	50	33		284	if($param->{memberof} && ref($param->{memberof}) eq 'ARRAY') {
8339	0				0	$cleaned{memberof} = $param->{memberof};
8340						}
8341
8342						# Handle object class
8343	177	100	100		291	if ($param->{isa} && !$cleaned{isa}) {
8344	4				6	$cleaned{isa} = $param->{isa};
8345						}
8346
8347						# Add format hints where available
8348	177	100			230	if ($param->{format}) {
8349	1				2	$cleaned{_format} = $param->{format};
8350						}
8351
8352						# Remove internal fields
8353	177				164	delete $cleaned{_source};
8354	177				151	delete $cleaned{_from_input_spec};
8355	177				139	delete $cleaned{semantic};
8356
8357	177				200	return \%cleaned;
8358						}
8359
8360						# --------------------------------------------------
8361						# _format_relationship
8362						#
8363						# Purpose: Format a relationship hashref as a
8364						# short human-readable description
8365						# string for use in YAML comments.
8366						#
8367						# Entry: $rel - relationship hashref as
8368						# produced by the relationship
8369						# detection methods.
8370						#
8371						# Exit: Returns a description string.
8372						# Returns 'Unknown relationship' for
8373						# unrecognised types.
8374						#
8375						# Side effects: None.
8376						# --------------------------------------------------
8377						sub _format_relationship {
8378	14			14	7835	my $rel = $_[0];
8379
8380	14	100 100 100 100 100 100			41	if ($rel->{type} eq 'mutually_exclusive') {
8381	3 3				3 11	return 'Mutually exclusive: ' . join(', ', @{$rel->{params}});
8382						} elsif ($rel->{type} eq 'required_group') {
8383	2 2				2 7	return "Required group (OR): " . join(', ', @{$rel->{params}});
8384						} elsif ($rel->{type} eq 'conditional_requirement') {
8385	2				6	return "If $rel->{if} then $rel->{then_required} required";
8386						} elsif ($rel->{type} eq 'dependency') {
8387	3				8	return "$rel->{param} depends on $rel->{requires}";
8388						} elsif ($rel->{type} eq 'value_constraint') {
8389	2				7	return "If $rel->{if} then $rel->{then} $rel->{operator} $rel->{value}";
8390						} elsif ($rel->{type} eq 'value_conditional') {
8391	1				4	return "If $rel->{if}='$rel->{equals}' then $rel->{then_required} required";
8392						}
8393	1				3	return 'Unknown relationship';
8394						}
8395
8396						# --------------------------------------------------
8397						# _needs_object_instantiation
8398						#
8399						# Purpose: Determine whether a method requires
8400						# an object to be instantiated before
8401						# it can be called, and if so return
8402						# the package name to instantiate.
8403						#
8404						# Entry: $method_name - name of the method.
8405						# $method_body - method source string.
8406						# $method_info - method hashref from
8407						# _find_methods (optional,
8408						# for backward compat).
8409						#
8410						# Exit: Returns the package name string if
8411						# object instantiation is required.
8412						# Returns undef if the method is a
8413						# constructor, factory, singleton, or
8414						# pure class method.
8415						#
8416						# Side effects: Logs analysis decisions to stdout
8417						# when verbose is set.
8418						#
8419						# Notes: Orchestrates five detection sub-steps:
8420						# factory detection, singleton detection,
8421						# instance method detection, inheritance
8422						# check, and constructor requirements.
8423						# Instance method detection overrides
8424						# factory detection when both fire.
8425						# --------------------------------------------------
8426						sub _needs_object_instantiation {
8427	333			333	2106	my ($self, $method_name, $method_body, $method_info) = @_;
8428
8429						# Allow method_info to be optional for backward compatibility
8430	333		50		457	$method_info \|\|= {};
8431
8432	333				470	my $doc = $self->{_document};
8433	333	50			794	return undef unless $doc;
8434
8435						# Get the current package name
8436	333				754	my $package_stmt = $doc->find_first('PPI::Statement::Package');
8437	333	100			43850	my $current_package = $package_stmt ? $package_stmt->namespace : 'UNKNOWN';
8438	333		67		5366	$self->{_package_name} //= $current_package;
8439
8440						# Initialize result structure
8441	333				1258	my $result = {
8442						package => $current_package,
8443						needs_object => 0,
8444						type => 'unknown',
8445						details => {},
8446						constructor_params => undef,
8447						};
8448
8449						# Track whether we should explicitly skip object instantiation
8450	333				351	my $skip_object = 0;
8451
8452						# Skip constructors and destructors
8453	333	100			599	if ($method_name eq 'new') {
8454	21				47	$self->_log(" OBJECT: Constructor '$method_name' detected; skipping instantiation analysis");
8455	21				43	return undef;
8456						}
8457	312	50			780	if($method_name =~ /^(create\|build\|construct\|init\|DESTROY)$/i) {
8458	0				0	$skip_object = 1;
8459						}
8460
8461						# 1. Check for factory methods that return instances
8462	312				788	my $is_factory = $self->_detect_factory_method(
8463						$method_name, $method_body, $current_package, $method_info
8464						);
8465
8466						# 2. Check for singleton patterns
8467	312				737	my $is_singleton = $self->_detect_singleton_pattern($method_name, $method_body);
8468	312	100			412	if ($is_singleton) {
8469	1				1	$result->{needs_object} = 0; # Singleton methods return the singleton instance
8470	1				2	$result->{type} = 'singleton_accessor';
8471	1				2	$result->{details} = $is_singleton;
8472	1				3	$self->_log(" OBJECT: Detected singleton accessor '$method_name'");
8473						# Singleton accessors typically don't need object creation in tests
8474						# as they're called on the class, not instance
8475	1				1	$skip_object = 1;
8476						}
8477
8478						# 3. Check if this is an instance method that needs an object
8479	312				693	my $is_instance_method = $self->_detect_instance_method($method_name, $method_body);
8480	312	0	50		689	if ($is_instance_method &&
8481						($is_instance_method->{explicit_self} \|\|
8482						$is_instance_method->{shift_self} \|\|
8483						$is_instance_method->{accesses_object_data} \|\|
8484						($is_instance_method->{calls_instance_methods} &&
8485						scalar @{$is_instance_method->{calls_instance_methods}}))) {
8486
8487						# Instance-only methods override factory detection
8488	160	100			262	if ($is_factory) {
8489	3				7	$self->_log(
8490						" OBJECT: Instance-only method '$method_name' overrides factory detection"
8491						);
8492						}
8493
8494	160				195	$result->{needs_object} = 1;
8495	160				199	$result->{type} = 'instance_method';
8496	160				177	$result->{details} = $is_instance_method;
8497
8498						# 4. Check for inheritance - if parent class constructor should be used
8499	160				362	my $inheritance_info = $self->_check_inheritance_for_constructor(
8500						$current_package, $method_body
8501						);
8502	160	50	67		370	if ($inheritance_info && $inheritance_info->{use_parent_constructor}) {
8503	0				0	$result->{package} = $inheritance_info->{parent_class};
8504	0				0	$result->{details}{inheritance} = $inheritance_info;
8505	0				0	$self->_log(
8506						" OBJECT: Method '$method_name' uses parent class constructor: $inheritance_info->{parent_class}"
8507						);
8508						}
8509
8510						# 5. Check if constructor needs specific parameters
8511						my $constructor_needs = $self->_detect_constructor_requirements(
8512						$current_package, $result->{package}
8513	160				527	);
8514	160	100			307	if ($constructor_needs) {
8515	3				6	$result->{constructor_params} = $constructor_needs;
8516	3				7	$result->{details}{constructor_requirements} = $constructor_needs;
8517	3				11	$self->_log(
8518						" OBJECT: Constructor for $result->{package} requires parameters"
8519						);
8520						}
8521
8522						# Return the package name (or parent package) that needs instantiation
8523	160				715	return $result->{package};
8524						}
8525
8526						# 6. Check for class methods that might need objects from other classes
8527	152				294	my $needs_other_object = $self->_detect_external_object_dependency($method_body);
8528	152	50			184	if ($needs_other_object) {
8529	0				0	$result->{needs_object} = 1;
8530	0				0	$result->{type} = 'external_dependency';
8531						$result->{package} = $needs_other_object->{package}
8532	0	0			0	if $needs_other_object->{package};
8533	0				0	$result->{details} = $needs_other_object;
8534
8535	0				0	$self->_log(
8536						" OBJECT: Method '$method_name' depends on external object: $needs_other_object->{package}"
8537						);
8538	0	0			0	return $result->{package} if $result->{package};
8539						}
8540
8541						# Factory method only if NOT instance-based
8542	152	100	100		196	if ($is_factory && !$skip_object) {
8543	1				2	$result->{needs_object} = 0;
8544	1				1	$result->{type} = 'factory';
8545	1				2	$result->{details} = $is_factory;
8546						$self->_log(
8547						" OBJECT: Detected factory method '$method_name' returns $is_factory->{returns_class} objects"
8548	1	50			4	) if $is_factory->{returns_class};
8549						}
8550
8551	152				273	return undef;
8552						}
8553
8554						# --------------------------------------------------
8555						# _detect_factory_method
8556						#
8557						# Purpose: Detect whether a method is a factory
8558						# that creates and returns object
8559						# instances rather than operating on
8560						# an existing instance.
8561						#
8562						# Entry: $method_name - method name string.
8563						# $method_body - method source string.
8564						# $current_package - current package name.
8565						# $method_info - method hashref
8566						# (optional).
8567						#
8568						# Exit: Returns a factory_info hashref on
8569						# detection, or undef if the method
8570						# is not a factory.
8571						# The hashref includes: returns_class,
8572						# confidence, and one of:
8573						# returns_blessed, returns_new,
8574						# returns_factory_result, pod_hint.
8575						#
8576						# Side effects: None.
8577						# --------------------------------------------------
8578						sub _detect_factory_method {
8579	318			318	12337	my ($self, $method_name, $method_body, $current_package, $method_info) = @_;
8580
8581	318				291	my %factory_info;
8582
8583						# Check method name patterns
8584	318	100			685	if ($method_name =~ /^(create_\|make_\|build_\|get_)/i) {
8585	11				20	$factory_info{name_pattern} = 1;
8586						}
8587
8588						# Look for object creation patterns in the method body
8589	318	50			471	if ($method_body) {
8590						# Pattern 1: Returns a blessed reference
8591	318	100	67		1458	if ($method_body =~ /return\s+bless\s\{[^}]\},\s['"]?(\w+(?:::\w+)\|\$\w+)['"]?/s \|\|
8592						$method_body =~ /bless\s\{[^}]\},\s['"]?(\w+(?:::\w+)\|\$\w+)['"]?.*return/s) {
8593	5				9	my $class_name = $1;
8594
8595						# Handle variable class names
8596	5	100 50			18	if ($class_name =~ /^\$(class\|self\|package)$/) {
8597	2				3	$factory_info{returns_class} = $current_package;
8598						} elsif ($class_name =~ /^\$/) {
8599	0				0	$factory_info{returns_class} = 'VARIABLE'; # Unknown variable
8600						} else {
8601	3				8	$factory_info{returns_class} = $class_name;
8602						}
8603
8604	5				10	$factory_info{returns_blessed} = 1;
8605	5				9	$factory_info{confidence} = 'high';
8606	5				10	return \%factory_info;
8607						}
8608
8609						# Pattern 2: Returns ->new() call on class or $self
8610	313	100	100		1205	if ($method_body =~ /return\s+([\$\w:]+)->new\(/s \|\|
8611						$method_body =~ /([\$\w:]+)->new\(.*return/s) {
8612	5				9	my $target = $1;
8613
8614						# Determine what class is being instantiated
8615	5	50 100	25		29	if ($target eq '$self' \|\| $target eq 'shift' \|\| $target =~ /^\$/) {
8616	0				0	$factory_info{returns_class} = $current_package;
8617	0				0	$factory_info{self_new} = 1;
8618						} elsif ($target =~ /::/) {
8619	1				2	$factory_info{returns_class} = $target;
8620	1				2	$factory_info{external_class} = 1;
8621						} else {
8622	4				7	$factory_info{returns_class} = $target;
8623						}
8624
8625	5				8	$factory_info{returns_new} = 1;
8626	5				6	$factory_info{confidence} = 'medium';
8627	5				10	return \%factory_info;
8628						}
8629
8630						# Pattern 3: Returns an object from another factory method
8631	308	50	33		1560	if ($method_body =~ /return\s+([\$\w:]+)->(create_\|make_\|build_\|get_)/i \|\|
8632						$method_body =~ /([\$\w:]+)->(create_\|make_\|build_\|get_).*return/si) {
8633	0				0	$factory_info{returns_factory_result} = 1;
8634	0				0	$factory_info{confidence} = 'low';
8635	0				0	return \%factory_info;
8636						}
8637						}
8638
8639						# Check for return type hints in POD if available
8640	308	100	50		1193	if ($method_info && ref($method_info) eq 'HASH' && $method_info->{pod}) {
8641	114				148	my $pod = $method_info->{pod};
8642	114	50			370	if ($pod =~ /returns?\s+(?:an?\s+)?(object\|instance\|new\s+\w+)/i) {
8643	0				0	$factory_info{pod_hint} = 1;
8644	0				0	$factory_info{confidence} = 'low';
8645	0				0	return \%factory_info;
8646						}
8647						}
8648
8649	308				416	return undef;
8650						}
8651
8652						# --------------------------------------------------
8653						# _detect_singleton_pattern
8654						#
8655						# Purpose: Detect singleton accessor methods
8656						# that return a shared instance rather
8657						# than creating a new object, by
8658						# checking the method name and body
8659						# for singleton patterns.
8660						#
8661						# Entry: $method_name - method name string.
8662						# $method_body - method source string.
8663						#
8664						# Exit: Returns a singleton_info hashref on
8665						# detection (always contains at least
8666						# name_pattern => 1), or undef if the
8667						# method name does not match the
8668						# singleton accessor pattern.
8669						#
8670						# Side effects: None.
8671						#
8672						# Notes: Only fires for methods named
8673						# instance, get_instance, singleton,
8674						# or shared_instance. Methods not
8675						# matching these names always return
8676						# undef regardless of body content.
8677						# --------------------------------------------------
8678						sub _detect_singleton_pattern {
8679	321			321	1167	my ($self, $method_name, $method_body) = @_;
8680
8681						# Check method name patterns
8682	321	100			772	return undef unless $method_name =~ /^(instance\|get_instance\|singleton\|shared_instance)$/i;
8683
8684	7				13	my %singleton_info = (
8685						name_pattern => 1,
8686						);
8687
8688						# Look for singleton patterns in code
8689	7	50			15	if ($method_body) {
8690						# Pattern 1: Static/state variable holding instance
8691	7	100	67		34	if ($method_body =~ /(?:my\s+)?(?:our\s+)?\$(?:instance\|_instance\|singleton)\b/s \|\|
8692						$method_body =~ /state\s+\$(?:instance\|_instance\|singleton)\b/s) {
8693	5				9	$singleton_info{static_variable} = 1;
8694	5				6	$singleton_info{confidence} = 'high';
8695						}
8696
8697						# Pattern 2: Returns $instance if defined (with better regex)
8698	7	100	67		35	if ($method_body =~ /return\s+\$instance\s+if\s+(?:defined\s+)?\$instance/ \|\|
8699						$method_body =~ /unless\s+\$instance.?=\s.*?new/) {
8700	1				2	$singleton_info{returns_instance} = 1;
8701	1				2	$singleton_info{confidence} = 'high';
8702						}
8703
8704						# Pattern 3: \|\|= new() pattern (with better regex)
8705	7	100	67		33	if ($method_body =~ /\$instance\s\\|\\|=\s.*?new/ \|\|
8706						$method_body =~ /\$instance\s=\s.*?new\s+unless\s+(?:defined\s+)?\$instance/) {
8707	3				3	$singleton_info{lazy_initialization} = 1;
8708	3				6	$singleton_info{confidence} = 'medium';
8709						}
8710
8711						# Pattern 4: Direct return of $instance variable
8712	7	100			19	if ($method_body =~ /return\s+\$instance;/) {
8713	4				7	$singleton_info{returns_instance} = 1;
8714	4	50			8	$singleton_info{confidence} = 'high' unless $singleton_info{confidence};
8715						}
8716						}
8717
8718	7	50			20	return \%singleton_info if keys %singleton_info > 0; # Need at least name pattern
8719
8720	0				0	return undef;
8721						}
8722
8723						# --------------------------------------------------
8724						# _detect_instance_method
8725						#
8726						# Purpose: Detect whether a method is an
8727						# instance method that requires a
8728						# blessed object ($self) to be called,
8729						# through multiple detection patterns
8730						# of varying confidence.
8731						#
8732						# Entry: $method_name - method name string.
8733						# $method_body - method source string.
8734						#
8735						# Exit: Returns an instance_info hashref if
8736						# any instance method signal is found.
8737						# Returns undef if no signals are
8738						# detected.
8739						# The hashref may contain: explicit_self,
8740						# shift_self, uses_self,
8741						# accesses_object_data,
8742						# calls_instance_methods,
8743						# private_method, and confidence.
8744						#
8745						# Side effects: None.
8746						# --------------------------------------------------
8747						sub _detect_instance_method {
8748	320			320	2751	my ($self, $method_name, $method_body) = @_;
8749
8750	320				325	my %instance_info;
8751
8752						# Pattern 1: my ($self, ...) = @_;
8753	320	100 100 100 100			1320	if ($method_body =~ /my\s\(\s\$self\s*[,)]/) {
8754	137				237	$instance_info{explicit_self} = 1;
8755	137				214	$instance_info{confidence} = 'high';
8756						}
8757
8758						# Pattern 1b: my $self = $_[0]; (direct-index style)
8759						elsif ($method_body =~ /my\s+\$self\s=\s\$_\[0\]/) {
8760	9				15	$instance_info{explicit_self} = 1;
8761	9				16	$instance_info{confidence} = 'high';
8762						}
8763
8764						# Pattern 2: my $self = shift;
8765						elsif ($method_body =~ /my\s+\$self\s=\sshift/) {
8766	18				77	$instance_info{shift_self} = 1;
8767	18				38	$instance_info{confidence} = 'high';
8768						}
8769
8770						# Pattern 3: Uses $self->something (including hash/array access)
8771						# This catches $self->{value} and $self->[0] as well as $self->method()
8772						elsif ($method_body =~ /\$self\s->\s(\w+\|[\{\[])/) {
8773	2				5	$instance_info{uses_self} = 1;
8774	2				4	$instance_info{confidence} = 'medium';
8775						}
8776
8777						# Pattern 4: Accesses object data: $self->{...}, $self->[...]
8778	320	100			740	if ($method_body =~ /\$self\s->\s[\{\[]/) {
8779	62				102	$instance_info{accesses_object_data} = 1;
8780	62	100			136	$instance_info{confidence} = 'high' unless $instance_info{confidence} eq 'high';
8781						}
8782
8783						# Pattern 5: Calls other instance methods on $self
8784	320	100			711	if ($method_body =~ /\$self\s->\s(\w+)\s*\(/s) {
8785	5				9	$instance_info{calls_instance_methods} = [];
8786	5				19	while ($method_body =~ /\$self\s->\s(\w+)\s*\(/g) {
8787	5 5				5 10	push @{$instance_info{calls_instance_methods}}, $1;
8788						}
8789	5 5	50			7 10	$instance_info{confidence} = 'high' if @{$instance_info{calls_instance_methods}};
8790						}
8791
8792						# Pattern 6: Method name suggests instance method (not perfect but helpful)
8793	320	100	67		613	if ($method_name =~ /^_/ && $method_name !~ /^_new/) {
8794						# Private methods are usually instance methods
8795	5				10	$instance_info{private_method} = 1;
8796	5	50			11	$instance_info{confidence} = 'low' unless exists $instance_info{confidence};
8797						}
8798
8799	320	100			512	return \%instance_info if keys %instance_info;
8800	149				161	return undef;
8801						}
8802
8803						# --------------------------------------------------
8804						# _check_inheritance_for_constructor
8805						#
8806						# Purpose: Determine whether the current package
8807						# uses an inherited constructor from a
8808						# parent class, by examining use parent,
8809						# use base, and @ISA declarations.
8810						#
8811						# Entry: $current_package - current package
8812						# name string.
8813						# $method_body - method source string
8814						# (checked for SUPER::
8815						# calls).
8816						#
8817						# Exit: Returns an inheritance_info hashref
8818						# if any inheritance information is
8819						# found, or undef otherwise.
8820						# The hashref may contain:
8821						# parent_statements, isa_array,
8822						# uses_super, calls_super_new,
8823						# has_own_constructor,
8824						# use_parent_constructor, parent_class.
8825						#
8826						# Side effects: None.
8827						# --------------------------------------------------
8828						sub _check_inheritance_for_constructor {
8829	163			163	13271	my ($self, $current_package, $method_body) = @_;
8830
8831	163				190	my $doc = $self->{_document};
8832	163	100			284	return undef unless $doc;
8833
8834	162				182	my %inheritance_info;
8835
8836						# 1. Look for parent/base statements
8837						my @parent_classes;
8838
8839						# Find all 'use parent' or 'use base' statements
8840	162		100		285	my $includes = $doc->find('PPI::Statement::Include') \|\| [];
8841	162				644269	foreach my $inc (@$includes) {
8842	311				404	my $content = $inc->content;
8843	311	100			3324	if ($content =~ /use\s+(parent\|base)\s+['"]?([\w:]+)['"]?/) {
8844	4				7	push @parent_classes, $2;
8845	4				7	$inheritance_info{parent_statements} = \@parent_classes;
8846						}
8847						# Also check for multiple parents: use parent qw(Class1 Class2)
8848	311	50			516	if ($content =~ /use\s+(parent\|base)\s+qw?[$\[]?(.+?)[$\]]?;/) {
8849	0				0	my $parents = $2;
8850	0				0	my @multi_parents = split /\s+/, $parents;
8851	0				0	push @parent_classes, @multi_parents;
8852	0				0	$inheritance_info{parent_statements} = \@parent_classes;
8853						}
8854						}
8855
8856						# 2. Look for @ISA assignments (with or without 'our')
8857	162		100		266	my $isas = $doc->find('PPI::Statement::Variable') \|\| [];
8858	162				643860	foreach my $isa (@$isas) {
8859	1005				940	my $content = $isa->content();
8860						# Match both "our @ISA = qw(...)" and "@ISA = qw(...)"
8861	1005	50			26999	if ($content =~ /(?:our\s+)?\@ISA\s=\sqw?[$\[]?(.+?)[$\]]?/) {
8862	0				0	my $parents = $1;
8863	0				0	my @isa_parents = split(/\s+/, $parents);
8864	0				0	push @parent_classes, @isa_parents;
8865	0				0	$inheritance_info{isa_array} = \@isa_parents;
8866						}
8867						}
8868
8869						# Also look for @ISA in regular statements
8870	162		50		266	my $statements = $doc->find('PPI::Statement') \|\| [];
8871	162				642647	foreach my $stmt (@$statements) {
8872	6315				5052	my $content = $stmt->content;
8873	6315	100			161846	if ($content =~ /\@ISA\s=\sqw?[$\[]?(.+?)[$\]]?/) {
8874	1				2	my $parents = $1;
8875	1				2	my @isa_parents = split(/\s+/, $parents);
8876	1				2	push @parent_classes, @isa_parents;
8877	1				2	$inheritance_info{isa_array} = \@isa_parents;
8878						}
8879						}
8880
8881						# 3. Check if method uses SUPER:: calls
8882	162	100	100		749	if ($method_body && $method_body =~ /SUPER::/) {
8883	2				4	$inheritance_info{uses_super} = 1;
8884	2	50			5	if ($method_body =~ /SUPER::new/) {
8885	0				0	$inheritance_info{calls_super_new} = 1;
8886						}
8887						}
8888
8889						# 4. Check if current package has its own new method
8890						my $has_own_new = $doc->find(sub {
8891	62077	100		62077	277815	$_[1]->isa('PPI::Statement::Sub') &&
8892						$_[1]->name eq 'new'
8893	162				526	});
8894
8895	162	100 100			1270	if ($has_own_new) {
8896	48				99	$inheritance_info{has_own_constructor} = 1;
8897						} elsif (@parent_classes) {
8898						# No own constructor, but has parents - might need parent constructor
8899	1				3	$inheritance_info{use_parent_constructor} = 1;
8900	1				3	$inheritance_info{parent_class} = $parent_classes[0]; # Use first parent
8901						}
8902
8903	162	100			410	return \%inheritance_info if keys %inheritance_info;
8904	113				345	return undef;
8905						}
8906
8907						# --------------------------------------------------
8908						# _detect_constructor_requirements
8909						#
8910						# Purpose: Analyse the new() method of the
8911						# current or target package to determine
8912						# what parameters the constructor
8913						# requires, including required and
8914						# optional parameters and their defaults.
8915						#
8916						# Entry: $current_package - the package being
8917						# analysed.
8918						# $target_package - the package whose
8919						# constructor will
8920						# be called (may
8921						# differ from current
8922						# for inherited
8923						# constructors).
8924						#
8925						# Exit: Returns a requirements hashref on
8926						# success, or undef if no new() method
8927						# is found. For external classes,
8928						# returns a minimal hashref with
8929						# external_class => 1.
8930						#
8931						# Side effects: None.
8932						# --------------------------------------------------
8933						sub _detect_constructor_requirements {
8934	164			164	16835	my ($self, $current_package, $target_package) = @_;
8935
8936	164				241	my $doc = $self->{_document};
8937	164	50			328	return undef unless $doc;
8938
8939						# If target is different from current, we can't analyze it
8940						# (external class, parent class in different file)
8941	164	100			298	if ($target_package ne $current_package) {
8942						return {
8943	1				7	external_class => 1,
8944						package => $target_package,
8945						note => "Constructor for external class $target_package - parameters unknown"
8946						};
8947						}
8948
8949						# Find the new method in current package
8950						my $new_method = $doc->find_first(sub {
8951	43458	100		43458	191044	$_[1]->isa('PPI::Statement::Sub') &&
8952						$_[1]->name eq 'new'
8953	163				519	});
8954
8955	163	100			2162	return undef unless $new_method;
8956
8957	49				57	my %requirements;
8958
8959						# Get method body
8960	49				78	my $body = $new_method->content;
8961
8962						# Look for parameter extraction patterns - handle both $self and $class
8963	49	100			4334	if ($body =~ /my\s$\s\$(self\|class)\s,\s(.+?)$\s=\s\@_/s) {
8964	40				73	my $params = $2;
8965	40				78	my @param_names = $params =~ /\$(\w+)/g;
8966
8967	40	100			76	if (@param_names) {
8968	3				7	$requirements{parameters} = \@param_names;
8969	3				8	$requirements{parameter_count} = scalar @param_names;
8970						}
8971						}
8972
8973						# Look for shift patterns
8974	49				57	my @shift_params;
8975	49				141	while ($body =~ /my\s+\$(\w+)\s=\sshift/g) {
8976	0				0	push @shift_params, $1;
8977						}
8978						# Remove $self or $class if present
8979	49 0				100 0	@shift_params = grep { $_ !~ /^(self\|class)$/i } @shift_params;
8980
8981	49	50			66	if (@shift_params) {
8982	0				0	$requirements{parameters} = \@shift_params;
8983	0				0	$requirements{parameter_count} = scalar @shift_params;
8984	0				0	$requirements{shift_pattern} = 1;
8985						}
8986
8987						# Look for validation of parameters (more flexible pattern)
8988	49				51	my @required_params;
8989	49	100			132	if ($body =~ /croak.unless.(?:defined\s+)?\$(\w+)/g) {
8990	4				8	push @required_params, $1;
8991						}
8992	49	100			132	if ($body =~ /die.unless.(?:defined\s+)?\$(\w+)/g) {
8993	1				2	push @required_params, $1;
8994						}
8995
8996	49	100			79	if (@required_params) {
8997	5				7	$requirements{required_parameters} = \@required_params;
8998						}
8999
9000						# Look for default values (optional parameters)
9001	49				59	my @optional_params;
9002						my %default_values;
9003
9004						# Use the new _extract_default_value method
9005						# Check for each parameter in the constructor body
9006	49	100			85	if ($requirements{parameters}) {
9007	3 3				3 5	foreach my $param (@{$requirements{parameters}}) {
9008	5				13	my $default = $self->_extract_default_value($param, $body);
9009	5	100			9	if (defined $default) {
9010	2				2	push @optional_params, $param;
9011	2				5	$default_values{$param} = $default;
9012						}
9013						}
9014						}
9015
9016	49	100			80	if (@optional_params) {
9017	2				3	$requirements{optional_parameters} = \@optional_params;
9018	2				3	$requirements{default_values} = \%default_values;
9019						}
9020
9021	49	100			90	return \%requirements if keys %requirements;
9022	44				92	return undef;
9023						}
9024
9025
9026						# --------------------------------------------------
9027						# _detect_external_object_dependency
9028						#
9029						# Purpose: Detect whether a method creates or
9030						# depends on objects from classes other
9031						# than the current package, by scanning
9032						# for ->new() calls on named classes
9033						# and method calls on typed variables.
9034						#
9035						# Entry: $method_body - method source string.
9036						# May be undef.
9037						#
9038						# Exit: Returns a dependency_info hashref if
9039						# external object usage is found, or
9040						# undef otherwise.
9041						# The hashref may contain:
9042						# creates_objects (arrayref of class
9043						# names), uses_objects (arrayref of
9044						# class names), and package (the primary
9045						# dependency class).
9046						#
9047						# Side effects: None.
9048						# --------------------------------------------------
9049						sub _detect_external_object_dependency {
9050	158			158	4336	my ($self, $method_body) = @_;
9051
9052	158	100			167	return undef unless $method_body;
9053
9054	157				139	my %dependency_info;
9055
9056						# Pattern 1: Creates objects of other classes with ->new() or ->create()
9057						# Reset pos for global match
9058	157				246	pos($method_body) = 0;
9059	157				475	while ($method_body =~ /(\w+(?:::\w+)*)->(?:new\|create)\(/g) {
9060	5				7	my $class = $1;
9061	5	100	50		24	next if $class eq 'main' \|\| $class eq '__PACKAGE__' \|\| $class =~ /^\$/;
9062	4 4				4 20	push @{$dependency_info{creates_objects}}, $class;
9063						}
9064
9065	157	100			257	if ($dependency_info{creates_objects}) {
9066						# Remove duplicates
9067	3				3	my %seen;
9068	3 4 3				4 10 5	$dependency_info{creates_objects} = [grep { !$seen{$_}++ } @{$dependency_info{creates_objects}}];
9069	3				6	$dependency_info{package} = $dependency_info{creates_objects}[0];
9070						}
9071
9072						# Pattern 2: Calls methods on objects from other classes
9073	157	100			263	if ($method_body =~ /\$(\w+)->\w+\(/) {
9074	3				5	my %object_vars;
9075						# Reset pos for global match â€” the if check above used a
9076						# non-/g match so it cannot have advanced pos, but the while
9077						# loop's own /g matches still need to start from the beginning.
9078	3				5	pos($method_body) = 0;
9079	3				18	while ($method_body =~ /\$(\w+)->\w+\(/g) {
9080	4				10	$object_vars{$1}++;
9081						}
9082
9083						# Try to determine type of object variables
9084	3				3	my @object_classes;
9085	3				6	foreach my $var (keys %object_vars) {
9086						# Look for type declarations or assignments
9087	4	100 50			283	if ($method_body =~ /my\s+\$$var\s=\s(\w+(?:::\w+)+)->(?:new\|create)/) {
9088	3				8	push @object_classes, $1;
9089						} elsif ($method_body =~ /my\s+\$$var\s=\s(\w+(?:::\w+)+)->/) {
9090	0				0	push @object_classes, $1;
9091						}
9092						}
9093
9094	3	50			6	if (@object_classes) {
9095	3				5	$dependency_info{uses_objects} = \@object_classes;
9096	3	100			8	$dependency_info{package} = $object_classes[0] unless $dependency_info{package};
9097						}
9098						}
9099
9100						# Pattern 3: Receives objects as parameters (type hints in comments/POD)
9101						# This would need integration with parameter analysis
9102
9103	157	100			196	return \%dependency_info if keys %dependency_info;
9104	153				180	return undef;
9105						}
9106
9107						# --------------------------------------------------
9108						# _get_parent_class
9109						#
9110						# Purpose: Find the first parent class of the
9111						# current package by searching the
9112						# PPI document for use parent, use base,
9113						# or our @ISA declarations.
9114						#
9115						# Entry: None (operates on $self->{_document}).
9116						#
9117						# Exit: Returns the parent class name string,
9118						# or undef if no parent is found.
9119						#
9120						# Side effects: None.
9121						# --------------------------------------------------
9122						sub _get_parent_class {
9123	2			2	3707	my $self = $_[0];
9124
9125	2				3	my $doc = $self->{_document};
9126	2	50			5	return unless $doc;
9127
9128						# Look for use parent statements
9129						my $parent_stmt = $doc->find_first(sub {
9130	68	50	50	68	377	$_[1]->isa('PPI::Statement::Include') &&
9131						$_[1]->type eq 'use' &&
9132						$_[1]->module =~ /^(parent\|base)$/ &&
9133						$_[1]->arguments =~ /['"](\w+(?:::\w+)*)['"]/
9134	2				9	});
9135	2	50			17	if ($parent_stmt) {
9136	0				0	my $parent = $1;
9137	0				0	return $parent;
9138						}
9139
9140						# Look for @ISA assignment
9141						my $isa_stmt = $doc->find_first(sub {
9142	68	100		68	424	$_[1]->isa('PPI::Statement') &&
9143						$_[1]->content =~ /our\s+\@ISA\s=\s$\s['"](\w+(?:::\w+))['"]\s*$/
9144	2				5	});
9145	2	50	33		13	if ($isa_stmt && $isa_stmt->content =~ /['"](\w+(?:::\w+)*)['"]/) {
9146	0				0	return $1;
9147						}
9148
9149	2				4	return;
9150						}
9151
9152						# --------------------------------------------------
9153						# _get_class_for_instance_method
9154						#
9155						# Purpose: Determine which class should be used
9156						# for object instantiation when testing
9157						# an instance method, preferring the
9158						# current package if it has a new()
9159						# method, falling back to the parent
9160						# class otherwise.
9161						#
9162						# Entry: None (operates on $self->{_document}).
9163						#
9164						# Exit: Returns the package name string to
9165						# use for instantiation. Returns
9166						# 'UNKNOWN_PACKAGE' if no package
9167						# statement is found.
9168						#
9169						# Side effects: Stores the package name in
9170						# $self->{_package_name} if not
9171						# already set.
9172						# --------------------------------------------------
9173						sub _get_class_for_instance_method {
9174	2			2	3476	my $self = $_[0];
9175
9176						# Get the current package
9177	2				3	my $doc = $self->{_document};
9178	2				6	my $package_stmt = $doc->find_first('PPI::Statement::Package');
9179	2	100			488	return 'UNKNOWN_PACKAGE' unless $package_stmt;
9180	1				5	my $package_name = $package_stmt->namespace;
9181	1		33		17	$self->{_package_name} //= $package_name;
9182
9183						# Check if the current package has a 'new' method
9184						my $has_new = $doc->find(sub {
9185	46	100		46	266	$_[1]->isa('PPI::Statement::Sub') && $_[1]->name eq 'new'
9186	1				4	});
9187
9188	1	50			8	if ($has_new) {
9189	1				2	return $package_name;
9190						}
9191
9192						# Otherwise, try to get the parent class
9193	0				0	my $parent = $self->_get_parent_class();
9194	0	0			0	return $parent if $parent;
9195
9196						# Fallback to current package
9197	0				0	return $package_name;
9198						}
9199
9200						# --------------------------------------------------
9201						# _extract_default_value
9202						#
9203						# Purpose: Extract a default value for a named
9204						# parameter from a method body by
9205						# matching multiple common Perl default
9206						# assignment idioms.
9207						#
9208						# Entry: $param - parameter name string.
9209						# $code - method body source string.
9210						#
9211						# Exit: Returns the cleaned default value
9212						# scalar on success, or undef if no
9213						# default assignment pattern is found.
9214						#
9215						# Side effects: None.
9216						#
9217						# Notes: Eight patterns are tried in order:
9218						# \|\|, //=, defined ternary, unless
9219						# defined, \|\|=, //, multi-line if
9220						# !defined, unless defined block.
9221						# Comment lines are stripped from the
9222						# code before matching to avoid false
9223						# positives. Delegates to
9224						# _clean_default_value for value
9225						# normalisation.
9226						# --------------------------------------------------
9227						sub _extract_default_value {
9228	253			253	11129	my ($self, $param, $code) = @_;
9229
9230	253	100	100		592	return undef unless $param && $code;
9231
9232						# Clean up the code for easier pattern matching
9233						# Remove comments to avoid false positives
9234	250				255	my $clean_code = $code;
9235	250				456	$clean_code =~ s/#.*$//gm;
9236	250				3346	$clean_code =~ s/^\s+\|\s+$//g;
9237
9238						# Pattern 1: $param = $param \|\| 'default_value'
9239						# Also handles: $param = $arg \|\| 'default'
9240	250	100			8421	if ($clean_code =~ /\$$param\s=\s(?:\$$param\|\$[a-zA-Z_]\w)\s\\|\\|\s*([^;]+)/) {
9241	12				20	my $default = $1;
9242	12				17	$default =~ s/\s;\s$//;
9243	12				22	$default = $self->_clean_default_value($default);
9244	12	50			35	return $default if defined $default;
9245						}
9246
9247						# Pattern 2: $param //= 'default_value'
9248	238	100			2972	if ($clean_code =~ /\$$param\s\/\/=\s([^;]+)/) {
9249	10				17	my $default = $1;
9250	10				12	$default =~ s/\s;\s$//;
9251	10				20	$default = $self->_clean_default_value($default);
9252	10	100			30	return $default if defined $default;
9253						}
9254
9255						# Pattern 3: $param = defined $param ? $param : 'default'
9256						# Also handles: $param = defined $arg ? $arg : 'default'
9257	229	100			11377	if ($clean_code =~ /\$$param\s=\sdefined\s+(?:\$$param\|\$[a-zA-Z_]\w)\s\?\s(?:\$$param\|\$[a-zA-Z_]\w)\s:\s([^;]+)/) {
9258	6				9	my $default = $1;
9259	6				10	$default =~ s/\s;\s$//;
9260	6				10	$default = $self->_clean_default_value($default);
9261	6	50			19	return $default if defined $default;
9262						}
9263
9264						# Pattern 4: $param = 'default' unless defined $param;
9265	223	100			7077	if ($clean_code =~ /\$$param\s=\s([^;]+?)\s+unless\s+defined\s+(?:\$$param\|\$[a-zA-Z_]\w*)/) {
9266	3				5	my $default = $1;
9267	3				6	$default = $self->_clean_default_value($default);
9268	3	50			10	return $default if defined $default;
9269						}
9270
9271						# Pattern 5: $param \|\|= 'default'
9272	220	100			2624	if ($clean_code =~ /\$$param\s\\|\\|=\s([^;]+)/) {
9273	5				8	my $default = $1;
9274	5				10	$default =~ s/\s;\s$//;
9275	5				12	$default = $self->_clean_default_value($default);
9276	5	50			20	return $default if defined $default;
9277						}
9278
9279						# Pattern 6: $param = $arg // 'default'
9280	215	100			6081	if ($clean_code =~ /\$$param\s=\s(?:\$$param\|\$[a-zA-Z_]\w)\s\/\/\s*([^;]+)/) {
9281	2				3	my $default = $1;
9282	2				4	$default =~ s/\s;\s$//;
9283	2				4	$default = $self->_clean_default_value($default);
9284	2	100			4	return $default if defined $default;
9285						}
9286
9287						# Pattern 7: Multi-line: if (!defined $param) { $param = 'default'; }
9288	214	100			5888	if ($clean_code =~ /if\s$\s!defined\s+\$$param\s$\s\{[^}]\$$param\s=\s*([^;]+)/s) {
9289	1				2	my $default = $1;
9290	1				2	$default =~ s/\s;\s$//;
9291	1				3	$default = $self->_clean_default_value($default);
9292	1	50			6	return $default if defined $default;
9293						}
9294
9295						# Pattern 8: unless (defined $param) { $param = 'default'; }
9296	213	100			5894	if ($clean_code =~ /unless\s$\sdefined\s+\$$param\s$\s\{[^}]\$$param\s=\s*([^;]+)/s) {
9297	1				2	my $default = $1;
9298	1				2	$default =~ s/\s;\s$//;
9299	1				2	$default = $self->_clean_default_value($default);
9300	1	50			4	return $default if defined $default;
9301						}
9302
9303	212				558	return undef;
9304						}
9305
9306						# --------------------------------------------------
9307						# _extract_test_hints
9308						#
9309						# Purpose: Extract structured test hints from
9310						# a method's code and schema, including
9311						# boundary values, invalid inputs, and
9312						# valid input examples from POD.
9313						#
9314						# Entry: $method - method hashref.
9315						# $schema - schema hashref as built so
9316						# far by _analyze_method.
9317						#
9318						# Exit: Returns a hints hashref with keys:
9319						# boundary_values, invalid_inputs,
9320						# equivalence_classes, valid_inputs.
9321						# Keys with empty arrays are deleted
9322						# before returning.
9323						#
9324						# Side effects: None.
9325						# --------------------------------------------------
9326						sub _extract_test_hints {
9327	331			331	477	my ($self, $method, $schema) = @_;
9328
9329	331				1066	my %hints = (
9330						boundary_values => [],
9331						invalid_inputs => [],
9332						equivalence_classes => [],
9333						valid_inputs => [],
9334						);
9335
9336	331				452	my $code = $method->{body};
9337	331	100			446	return {} unless $code;
9338
9339	330				876	$self->_extract_invalid_input_hints($code, \%hints);
9340	330				774	$self->_extract_boundary_value_hints($code, \%hints);
9341
9342						# prune empties
9343	330				567	for my $k (keys %hints) {
9344	1320 1320	100			806 1499	delete $hints{$k} unless @{$hints{$k}};
9345						}
9346
9347	330				495	return \%hints;
9348						}
9349
9350						# --------------------------------------------------
9351						# _extract_invalid_input_hints
9352						#
9353						# Purpose: Detect likely invalid input values
9354						# from a method body by looking for
9355						# defined checks, empty string checks,
9356						# and negative number checks.
9357						#
9358						# Entry: $code - method body source string.
9359						# $hints - hints hashref (modified in
9360						# place via invalid_inputs key).
9361						#
9362						# Exit: Returns nothing. Appends to
9363						# $hints->{invalid_inputs}.
9364						#
9365						# Side effects: None.
9366						# --------------------------------------------------
9367						sub _extract_invalid_input_hints {
9368	337			337	872	my ($self, $code, $hints) = @_;
9369
9370						# undef invalid
9371	337	100			730	if ($code =~ /defined\s\(\s\$/) {
9372	6 6				8 12	push @{ $hints->{invalid_inputs} }, 'undef';
9373						}
9374
9375						# empty string invalid
9376	337	100	100		1076	if ($code =~ /\beq\s''/ \|\| $code =~ /\blength\s\(/) {
9377	12 12				14 20	push @{ $hints->{invalid_inputs} }, '';
9378						}
9379
9380						# negative number invalid
9381	337	100			694	if ($code =~ /\$\w+\s<\s0/) {
9382	8 8				7 17	push @{ $hints->{invalid_inputs} }, -1;
9383						}
9384						}
9385
9386						# --------------------------------------------------
9387						# _extract_boundary_value_hints
9388						#
9389						# Purpose: Extract numeric boundary values from
9390						# comparison operators in a method body,
9391						# adding both the boundary value and
9392						# the value one step either side.
9393						#
9394						# Entry: $code - method body source string.
9395						# $hints - hints hashref (modified in
9396						# place via boundary_values key).
9397						#
9398						# Exit: Returns nothing. Appends to and
9399						# deduplicates $hints->{boundary_values}.
9400						#
9401						# Side effects: None.
9402						# --------------------------------------------------
9403						sub _extract_boundary_value_hints {
9404	335			335	890	my ($self, $code, $hints) = @_;
9405
9406	335				1106	while ($code =~ /\$\w+\s(<=\|<\|>=\|>)\s(\d+)/g) {
9407	29				55	my ($op, $n) = ($1, $2);
9408
9409	29	100 100 100 50			79	if ($op eq '<') {
9410	12 12				14 35	push @{ $hints->{boundary_values} }, $n, $n+1;
9411						} elsif ($op eq '<=') {
9412	2 2				2 8	push @{ $hints->{boundary_values} }, $n, $n+1;
9413						} elsif ($op eq '>') {
9414	13 13				13 177	push @{ $hints->{boundary_values} }, $n, $n-1;
9415						} elsif ($op eq '>=') {
9416	2 2				2 6	push @{ $hints->{boundary_values} }, $n, $n-1;
9417						}
9418						}
9419
9420						# Remove duplicates
9421	335				348	my %seen;
9422	335 58 335				324 141 799	$hints->{boundary_values} = [ grep { !$seen{$_}++ } @{ $hints->{boundary_values} } ];
9423						}
9424
9425						# --------------------------------------------------
9426						# _extract_pod_examples
9427						#
9428						# Purpose: Extract example method call patterns from a method's
9429						# SYNOPSIS section (=head1 or =head2) and from any
9430						# =for example begin/end blocks, and add them as
9431						# valid_inputs hints for fuzzing.
9432						#
9433						# Entry: $pod - POD string for the method. May be undef.
9434						# $hints - hints hashref (modified in place via the
9435						# valid_inputs key).
9436						#
9437						# Exit: Returns $hints. Appends to $hints->{valid_inputs}.
9438						#
9439						# Side effects: Logs the number of examples found to stdout when
9440						# verbose is set.
9441						#
9442						# Notes: For standalone runnable round-trip tests (not just
9443						# fuzzing hints) use App::Test::Generator::PodExampleExtractor
9444						# and bin/pod-example-tester instead.
9445						# --------------------------------------------------
9446						sub _extract_pod_examples {
9447	334			334	470	my ($self, $pod, $hints) = @_;
9448
9449	334	100			436	return $hints unless $pod;
9450
9451	134				134	my @examples;
9452
9453						# Accept both =head1 SYNOPSIS (module-level) and =head2 SYNOPSIS (method-level)
9454	134				150	my $synopsis = '';
9455	134	100			367	if($pod =~ /=head[12]\s+SYNOPSIS\s*(.+?)(?=\n=head\|\z)/s) {
9456	8				11	$synopsis = $1;
9457						}
9458
9459						# Also collect =for example begin ... =for example end blocks
9460	134				135	my @for_blocks;
9461	134				315	while($pod =~ /=for\s+example\s+begin(.+?)=for\s+example\s+end/sg) {
9462	1				3	push @for_blocks, $1;
9463						}
9464	134				196	$synopsis .= join('', @for_blocks);
9465
9466	134	100			263	return $hints unless length($synopsis);
9467
9468						# Constructor examples: ->wilma(foo => 'bar', count => 5)
9469	9				40	while ($synopsis =~ /->([a-z_0-9A-Z]+)\s$\s(.?)\s$/sg) {
9470	12				24	my ($method, $args) = ($1, $2);
9471	12				12	my %kv;
9472
9473	12				40	while ($args =~ /(\w+)\s=>\s(?:'([^'])'\|"([^"])"\|(\d+))/g) {
9474	10				10	my $key = $1;
9475	10	50 100			29	my $val = defined $2 ? $2 : defined $3 ? $3 : $4;
9476	10				18	$kv{$key} = $val;
9477						}
9478
9479	12	100			39	push @examples, {
9480						style => 'named',
9481						source => 'pod',
9482						args => \%kv,
9483						function => $method, # TODO: add a sanity check this is what we expect
9484						} if %kv;
9485						}
9486
9487	9	100			13	unless(scalar(@examples)) {
9488						# Positional calls: func($a, $b)
9489	4				25	while ($synopsis =~ /\b(\w+)\s$\s(.?)\s$/sg) {
9490	11				14	my ($func, $argstr) = ($1, $2);
9491
9492						# next if $func eq 'new'; # already handled
9493
9494	11 9				22 22	my @args = map { s/^\s+\|\s+$//gr } split /\s,\s/, $argstr;
9495
9496	11	100			15	next unless @args;
9497
9498	8				39	push @examples, {
9499						style => 'positional',
9500						source => 'pod',
9501						function => $func,
9502						args => \@args,
9503						};
9504						}
9505						}
9506
9507	9	50			13	if (scalar(@examples)) {
9508	9		100		19	$hints->{valid_inputs} \|\|= [];
9509	9 9				9 15	push @{ $hints->{valid_inputs} }, @examples;
9510
9511	9				18	$self->_log(" POD: extracted " . scalar(@examples) . " example call(s)");
9512						}
9513
9514	9				16	for my $k (qw(boundary_values invalid_inputs valid_inputs equivalence_classes)) {
9515	36		100		60	$hints->{$k} //= [];
9516						}
9517
9518	9				13	return $hints;
9519						}
9520
9521						# --------------------------------------------------
9522						# _clean_default_value
9523						#
9524						# Purpose: Normalise a raw default value string
9525						# extracted from code or POD into a
9526						# clean Perl scalar, handling quoted
9527						# strings, numeric literals, boolean
9528						# keywords, empty containers, and
9529						# undef.
9530						#
9531						# Entry: $value - raw value string.
9532						# May be undef.
9533						# $from_code - true if the value was
9534						# extracted from source
9535						# code (affects escape
9536						# sequence handling).
9537						#
9538						# Exit: Returns the cleaned value:
9539						# undef for undef or unparseable
9540						# {} for empty hashrefs
9541						# [] for empty arrayrefs
9542						# integer for whole numbers
9543						# float for decimal numbers
9544						# 1 or 0 for boolean keywords
9545						# string for everything else
9546						#
9547						# Side effects: None.
9548						# --------------------------------------------------
9549						sub _clean_default_value {
9550	177			177	252	my ($self, $value, $from_code) = @_;
9551
9552	177	100			223	return unless defined $value;
9553
9554						# Remove leading/trailing whitespace
9555	175				362	$value =~ s/^\s+\|\s+$//g;
9556
9557						# Remove parenthetical notes like "(no password)" only if there's content before them
9558	175				192	$value =~ s/(\S+)\s$[^)]+$\s$/$1/;
9559	175				288	$value =~ s/^\s+\|\s+$//g;
9560
9561						# Handle chained \|\| or // operators - extract the rightmost value
9562	175	100			367	if ($value =~ /\\|\\|\|\/{2}/) {
9563	7				28	my @parts = split(/\s(?:\\|\\|\|\/{2})\s/, $value);
9564	7				8	$value = $parts[-1];
9565	7				30	$value =~ s/^\s+\|\s+$//g;
9566						}
9567
9568						# Remove trailing semicolon if present
9569	175				212	$value =~ s/;\s*$//;
9570
9571						# Handle q{}, qq{}, qw{} quotes
9572	175	100 50 50			426	if ($value =~ /^qq?\{(.*?)\}$/s) {
9573	3				5	$value = $1;
9574						} elsif ($value =~ /^qw\{(.*?)\}$/s) {
9575	0				0	$value = $1;
9576						} elsif ($value =~ /^q[qwx]?\s([^a-zA-Z0-9\{\[])(.?)\1$/s) {
9577	0				0	$value = $2;
9578						}
9579
9580						# Handle quoted strings
9581	175	100			321	if ($value =~ /^(['"])(.*)\1$/s) {
9582	50				58	$value = $2;
9583
9584	50	100			70	if ($from_code) {
9585						# In regex captures from source code, escape sequences are doubled
9586						# \\n in capture needs to become \n for the test
9587	18				20	$value =~ s/\\\\/\\/g;
9588						}
9589
9590						# Only unescape the quote characters themselves
9591	50				61	$value =~ s/\\"/"/g;
9592	50				52	$value =~ s/\\'/'/g;
9593
9594						# If NOT from code (i.e., from POD), interpret escape sequences
9595	50	100			62	unless ($from_code) {
9596	32				34	$value =~ s/\\n/\n/g;
9597	32				27	$value =~ s/\\r/\r/g;
9598	32				31	$value =~ s/\\t/\t/g;
9599	32				35	$value =~ s/\\\\/\\/g;
9600						}
9601						}
9602
9603						# Sometimes trailing ) is left on
9604	175	100			250	if($value !~ /^\(/) {
9605	173				168	$value =~ s/\)$//;
9606						}
9607
9608						# Handle Perl empty hash (must be before numeric/boolean checks)
9609	175	100			234	if ($value =~ /^\{\s*\}$/) {
9610	6				10	return {};
9611						}
9612
9613						# Handle Perl empty list/array
9614	169	100			222	if ($value =~ /^\[\s*\]$/) {
9615	6				12	return [];
9616						}
9617
9618						# Handle numeric values
9619	163	100			338	if ($value =~ /^-?\d+(?:\.\d+)?$/) {
9620	68	100			91	if ($value =~ /\./) {
9621	11				45	return $value + 0;
9622						} else {
9623	57				126	return int($value);
9624						}
9625						}
9626
9627						# Handle boolean keywords
9628	95	100			185	if ($value =~ /^(true\|false)$/i) {
9629	9	100			37	return lc($1) eq 'true' ? 1 : 0;
9630						}
9631
9632						# Handle Perl boolean constants
9633	86	50 50			222	if ($value eq '1') {
9634	0				0	return 1;
9635						} elsif ($value eq '0') {
9636	0				0	return 0;
9637						}
9638
9639						# Handle undef
9640	86	100			109	if ($value eq 'undef') {
9641	12				24	return undef;
9642						}
9643
9644						# Handle __PACKAGE__ and similar constants
9645	74	100			104	if ($value eq '__PACKAGE__') {
9646	1				3	return '__PACKAGE__';
9647						}
9648
9649						# Remove surrounding parentheses
9650	73				92	$value =~ s/^$(.+)$$/$1/;
9651
9652						# Handle expressions we can't evaluate
9653	73	100	100		208	if ($value =~ /^\$[a-zA-Z_]/ \|\| $value =~ /$.*$/) {
9654	4	100			18	return if($value =~ /^\$\|\@\|\%/); # The default is a value, so who knows its type?
9655						# return $value;
9656						}
9657
9658	72				133	return $value;
9659						}
9660
9661						# --------------------------------------------------
9662						# _validate_pod_code_agreement
9663						#
9664						# Purpose: Compare POD parameter documentation
9665						# against code-inferred parameters and
9666						# return a list of disagreements when
9667						# strict_pod mode is enabled.
9668						#
9669						# Entry: $pod_params - hashref of parameters
9670						# from POD analysis.
9671						# $code_params - hashref of parameters
9672						# from code analysis.
9673						# $method_name - method name string,
9674						# used for context in
9675						# error messages.
9676						#
9677						# Exit: Returns a list of disagreement
9678						# strings. Returns an empty list if
9679						# all parameters agree.
9680						#
9681						# Side effects: None.
9682						#
9683						# Notes: Type mismatches are classified as
9684						# either 'compatible' (e.g. integer vs
9685						# number) or 'incompatible' via
9686						# _types_are_compatible. $self and
9687						# $class are excluded from undocumented
9688						# parameter warnings in appropriate
9689						# context.
9690						# --------------------------------------------------
9691						sub _validate_pod_code_agreement {
9692	23			23	1623	my ($self, $pod_params, $code_params, $method_name) = @_;
9693
9694	23				24	my @errors;
9695
9696						# Get all parameter names from both sources
9697	23 38				50 67	my %all_params = map { $_ => 1 } (keys %$pod_params, keys %$code_params);
9698
9699	23				54	foreach my $param (sort keys %all_params) {
9700	30		100		102	my $pod = $pod_params->{$param} \|\| {};
9701	30		100		46	my $code = $code_params->{$param} \|\| {};
9702
9703						# Params from a =head3\|4 Input formal spec are the authoritative API
9704						# definition â€” they are exempt from POD/code disagreement checks since
9705						# the spec takes precedence over heuristic code analysis.
9706	30	50			45	next if $pod->{_from_input_spec};
9707
9708						# Check if parameter exists in both
9709	30	100	100		69	if (exists $pod_params->{$param} && !exists $code_params->{$param}) {
9710	3				5	push @errors, "Parameter '\$$param' documented in POD but not found in code signature";
9711	3				4	next;
9712						}
9713
9714	27	50	67		65	if(!exists $pod_params->{$param} && exists $code_params->{$param}) {
9715	19	100			34	if($param eq 'class') {
9716						# $class is the class invocant, not a user-facing parameter
9717	1				3	next;
9718						}
9719	18	100			30	if($param eq 'self') {
9720						# $self is the instance invocant, not a user-facing parameter
9721	1				2	next;
9722						}
9723	17				25	push @errors, "Parameter '\$$param' found in code but not documented in POD";
9724	17				22	next;
9725						}
9726
9727						# Compare types if both exist
9728	8	100	75		33	if ($pod->{type} && $code->{type} && $pod->{type} ne $code->{type}) {
9729	2	100			7	if (!$self->_types_are_compatible($pod->{type}, $code->{type})) {
9730	1				3	push @errors, "Type mismatch for '\$$param': POD says '$pod->{type}', code suggests '$code->{type}' (incompatible)";
9731						} else {
9732	1				3	push @errors, "Type difference for '\$$param': POD says '$pod->{type}', code suggests '$code->{type}' (compatible)";
9733						}
9734						}
9735
9736						# Compare optional status if both exist
9737	8	100	75		27	if (exists $pod->{optional} && exists $code->{optional} &&
9738						$pod->{optional} != $code->{optional}) {
9739	2	100			4	my $pod_status = $pod->{optional} ? 'optional' : 'required';
9740	2	100			23	my $code_status = $code->{optional} ? 'optional' : 'required';
9741	2				5	push @errors, "Optional status mismatch for '\$$param': POD says '$pod_status', code suggests '$code_status'";
9742						}
9743
9744						# Check constraints (min/max)
9745	8	0	25		15	if (defined $pod->{min} && defined $code->{min} && $pod->{min} != $code->{min}) {
9746	0				0	push @errors, "Min constraint mismatch for '\$$param': POD says '$pod->{min}', code suggests '$code->{min}'";
9747						}
9748
9749	8	0	25		18	if (defined $pod->{max} && defined $code->{max} && $pod->{max} != $code->{max}) {
9750	0				0	push @errors, "Max constraint mismatch for '\$$param': POD says '$pod->{max}', code suggests '$code->{max}'";
9751						}
9752
9753						# Check regex patterns
9754	8	0	25		17	if ($pod->{matches} && $code->{matches} && $pod->{matches} ne $code->{matches}) {
9755	0				0	push @errors, "Pattern mismatch for '\$$param': POD says '$pod->{matches}', code suggests '$code->{matches}'";
9756						}
9757						}
9758
9759						# Return errors (empty array if no errors)
9760	23				51	return @errors;
9761						}
9762
9763						# --------------------------------------------------
9764						# _validate_strictness_level
9765						#
9766						# Purpose: Validate and normalise the strict_pod
9767						# option value accepted by new() into
9768						# an integer level: 0 (off), 1 (warn),
9769						# or 2 (fatal).
9770						#
9771						# Entry: $val - the raw value passed to
9772						# strict_pod in new(). May be
9773						# undef, a number, or a string.
9774						#
9775						# Exit: Returns 0, 1, or 2.
9776						# Croaks if the value is not recognised.
9777						#
9778						# Side effects: None.
9779						# --------------------------------------------------
9780						sub _validate_strictness_level {
9781	501			501	14249	my $val = $_[0];
9782
9783	501	100			1792	return 0 unless defined $val;
9784
9785						# Numeric
9786	38	100			154	return 0 if $val =~ /^(0\|off\|none)$/i;
9787	29	100			114	return 1 if $val =~ /^(1\|warn\|warning)$/i;
9788	12	100			51	return 2 if $val =~ /^(2\|fatal\|die\|error)$/i;
9789
9790	2				23	croak("Invalid value for --strict-pod: '$val' (use off\|warn\|fatal)");
9791						}
9792
9793						# --------------------------------------------------
9794						# _types_are_compatible
9795						#
9796						# Purpose: Determine whether two type strings
9797						# are compatible for POD/code agreement
9798						# checking, allowing semantically
9799						# equivalent types (e.g. 'integer' and
9800						# 'number') to coexist without
9801						# triggering a strict POD warning.
9802						#
9803						# Entry: $pod_type - type string from POD.
9804						# $code_type - type string from code.
9805						#
9806						# Exit: Returns 1 if compatible, 0 otherwise.
9807						#
9808						# Side effects: None.
9809						# --------------------------------------------------
9810						sub _types_are_compatible {
9811	20			20	39	my ($self, $pod_type, $code_type) = @_;
9812
9813						# Exact match is always compatible
9814	20	100			35	return 1 if $pod_type eq $code_type;
9815
9816						# Define compatibility matrix
9817	15				45	my %compatible_types = (
9818						'integer' => ['number', 'scalar'],
9819						'number' => ['scalar'],
9820						'string' => ['scalar'],
9821						'scalar' => ['string', 'integer', 'number'],
9822						'arrayref' => ['array'],
9823						'hashref' => ['hash'],
9824						);
9825
9826						# Check if code_type is compatible with pod_type
9827	15	100			21	if (my $allowed = $compatible_types{$pod_type}) {
9828	13 17				15 40	return grep { $_ eq $code_type } @$allowed;
9829						}
9830
9831						# Check if pod_type is compatible with code_type
9832	2	50			5	if (my $allowed = $compatible_types{$code_type}) {
9833	2 2				2 7	return grep { $_ eq $pod_type } @$allowed;
9834						}
9835
9836	0				0	return 0; # Not compatible
9837						}
9838
9839 - 9888						=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
9889
9890						sub generate_pod_validation_report {
9891	17			17	1757	my ($self, $schemas) = @_;
9892
9893	17				18	my @reports;
9894	17				38	foreach my $method_name (sort keys %$schemas) {
9895	26				23	my $schema = $schemas->{$method_name};
9896
9897	26	100			41	if (my $errors = $schema->{_pod_validation_errors}) {
9898	16				22	push @reports, "Method: $method_name";
9899	16	100			32	push @reports, " Severity: " . ($schema->{_pod_disagreement} ? 'warning' : 'fatal');
9900	16				16	push @reports, " Errors:";
9901	16 16				17 23	push @reports, map { " - $_" } @$errors;
9902	16				20	push @reports, '';
9903						}
9904						}
9905
9906	17	100			26	if (@reports) {
9907	11				30	return join("\n", "POD/Code Validation Report:", '=' x 40, '', @reports);
9908						} else {
9909	6				10	return 'POD/Code Validation: All methods passed consistency checks.';
9910						}
9911						}
9912
9913 - 9917						=head2 _log Log a message if verbose mode is on. =cut
9918
9919						sub _log {
9920	4986			4986	6985	my($self, $msg) = @_;
9921
9922	4986	100			6853	print "$msg\n" if $self->{verbose};
9923						}
9924
9925 - 9967						=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
9968
9969						1;