view release on metacpan or  search on metacpan

lib/App/Test/Generator/SchemaExtractor.pm  view on Meta::CPAN

				my ($name) = grep { ($params{$_}{position} // -1) == $idx }
				             keys %params;
				if (defined $name) {
					$params{$name}{_from_input_spec} = 1;
					if (my $t = $self->_map_formal_input_type($spec)) {
						$params{$name}{type} = $t;
						$self->_log("  POD: $name type '$t' from =head Input (positional $idx)");
					}
					if ($spec =~ /\boptional\s*=>\s*(0|1)/i) {
						$params{$name}{optional} = $1 + 0;
					}
				}
				$idx++;
			}
		} elsif ($block =~ /\A\{/) {
			# Named format: each 'name => {…}' entry maps directly by name.
			while ($block =~ /\b(\w+)\s*=>\s*\{([^}]*)\}/g) {
				my ($name, $spec) = ($1, $2);
				next if $name =~ /^(self|class)$/i;
				$params{$name} //= { _source => 'pod' };
				$params{$name}{_from_input_spec} = 1;
				if (my $t = $self->_map_formal_input_type($spec)) {
					$params{$name}{type} = $t;
					$self->_log("  POD: $name type '$t' from =head Input (named)");
				}
				if ($spec =~ /\boptional\s*=>\s*(0|1)/i) {
					$params{$name}{optional} = $1 + 0;
				}
				if ($spec =~ /\bmemberof\s*=>\s*\[([^\]]*)\]/i) {
					my $list_str = $1;
					my @vals;
					while ($list_str =~ /['"]([^'"]*)['"]/g) {
						push @vals, $1;
					}
					$params{$name}{memberof} = \@vals if @vals;
				}
				if ($spec =~ /\bmin\s*=>\s*(\d+)/i) {
					$params{$name}{min} = $1 + 0;
				}
				if ($spec =~ /\bmax\s*=>\s*(\d+)/i) {
					$params{$name}{max} = $1 + 0;
				}
				if ($spec =~ /\bisa\s*=>\s*['"]([^'"]+)['"]/i) {
					$params{$name}{isa} = $1;
				}
			}
			# A named-format Input spec signals a hash/named API.  Positional
			# info from signature analysis is not meaningful here and causes
			# "param X missing position" errors when params are mixed.
			delete $params{$_}{position} for keys %params;
		}
	}

	return \%params;
}

# --------------------------------------------------
# _map_formal_input_type
#
# Purpose:    Extract and normalise the type string
#             from a parameter spec fragment such as
#             "type => 'scalar | scalarref'".
#             Handles union types by returning the
#             canonical ATG type for the first
#             recognised alternative.
#
# Entry:      $spec - text content of a { } block
#                     from a =head3|4 Input spec.
#
# Exit:       Canonical type string, or undef when
#             no 'type' key is present or the value
#             is not a recognised type name.
# --------------------------------------------------
sub _map_formal_input_type {
	my ($self, $spec) = @_;
	# Accept both quoted  type => 'scalar'  and unquoted Params::Validate
	# constants  type => OBJECT  (no quotes around the constant name).
	return undef unless $spec =~ /\btype\s*=>\s*(?:['"]([^'"]+)['"]|([A-Z_]+))/i;
	my $raw = lc(defined($1) ? $1 : $2);
	$raw =~ s/\s+//g;

	my %map = (
		scalar    => 'string',
		scalarref => 'string',
		str       => 'string',
		string    => 'string',
		int       => 'integer',
		integer   => 'integer',
		num       => 'number',
		number    => 'number',
		float     => 'number',
		bool      => 'boolean',
		boolean   => 'boolean',
		array     => 'arrayref',
		arrayref  => 'arrayref',
		hash      => 'hashref',
		hashref   => 'hashref',
		object    => 'object',
		any       => 'any',
		undef     => 'undef',
		coderef   => 'coderef',
	);

	for my $t (split /\|/, $raw) {
		return $map{$t} if exists $map{$t};
	}
	return undef;
}

# --------------------------------------------------
# _analyze_output
#
# Purpose:    Orchestrate analysis of a method's
#             return value by combining POD return
#             section parsing, code return statement
#             analysis, boolean detection, context
#             detection, void detection, chaining
#             detection, and error convention
#             detection.
#
# Entry:      $pod         - POD string for the method.