view release on metacpan or  search on metacpan

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

		my $schema = $self->_extract_schema_hash_from_block($schema_block);
		return $self->_normalize_validator_schema($schema) if $schema;
	}

	return;
}

# --------------------------------------------------
# _extract_pv_schema
#
# Purpose:    Detect and extract a parameter schema
#             from a Params::Validate validate()
#             call in the method body.
#
# Entry:      $code - method body source string.
#
# Exit:       Returns a schema hashref with input,
#             style, and source keys on success,
#             or undef if no validate() call is
#             found or parsing fails.
#
# Side effects: None.
# --------------------------------------------------
sub _extract_pv_schema {
	my ($self, $code) = @_;

	return unless $code =~ /\bvalidate\s*\(/;

	my $doc = $self->_ppi($code) or return;

	my $calls = $doc->find(sub {
		$_[1]->isa('PPI::Token::Word') && ($_[1]->content eq 'validate' || $_[1]->content eq 'Params::Validate::validate')
	}) or return;

	for my $call (@$calls) {
		my $list = $call->parent;
		while ($list && !$list->isa('PPI::Structure::List')) {
			$list = $list->parent;
		}
		if(!defined($list)) {
			my $next = $call->next_sibling();
			my ($arglist, $schema_text) = $self->_parse_pv_call($next);

			if($schema_text) {
				my $compartment = Safe->new();
				$compartment->permit_only(qw(:base_core :base_mem :base_orig));

				my $schema_str = "my \$schema = $schema_text";
				my $schema = $compartment->reval($schema_str);

				if(scalar keys %{$schema}) {
					foreach my $arg(keys %{$schema}) {
						my $field = $schema->{$arg};
						if(my $type = $field->{'type'}) {
							if($type eq 'ARRAYREF') {
								$field->{'type'} = 'arrayref';
							} elsif($type eq 'SCALAR') {
								$field->{'type'} = 'string';
							}
						}
						delete $field->{'callbacks'};
					}

					return {
						input => $schema,
						style => 'hash',
						source => 'validator'
					}
				}
			}
		}
		next unless $list;

		my ($schema_block) = grep { $_->isa('PPI::Structure::Block') } $list->children;

		next unless $schema_block;

		my $schema = $self->_extract_schema_hash_from_block($schema_block);
		return $self->_normalize_validator_schema($schema) if $schema;
	}

	return;
}

# --------------------------------------------------
# _parse_pv_call
#
# Purpose:    Split a Params::Validate call argument
#             string into its two components: the
#             first argument (typically \@_) and
#             the schema hash string.
#
# Entry:      $string - the raw argument string
#                       from the validate() call,
#                       including outer parentheses.
#
# Exit:       Returns a two-element list:
#               ($first_arg, $hash_str)
#             or an empty list if no comma is found
#             at brace depth zero (malformed call).
#
# Side effects: None.
# --------------------------------------------------
sub _parse_pv_call {
	my ($self, $string) = @_;

	# Remove outer parentheses and whitespace
	$string =~ s/^\s*\(\s*//;
	$string =~ s/\s*\)\s*$//;

	# Find the first comma at brace-depth 0
	my $depth = 0;
	my $comma_pos;

	for my $i (0 .. length($string) - 1) {
		my $char = substr($string, $i, 1);

		if ($char eq '{') {
			$depth++;
		} elsif ($char eq '}') {
			$depth--;

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

#             or undef if no validated_hash() call
#             is found or parsing fails.
#
# Side effects: None.
# --------------------------------------------------
sub _extract_moosex_params_schema
{
	my ($self, $code) = @_;

	return unless $code =~ /\bvalidated_hash\s*\(/;

	my $doc = $self->_ppi($code) or return;

	my $calls = $doc->find(sub {
		$_[1]->isa('PPI::Token::Word') && ($_[1]->content eq 'validated_hash')
	}) or return;

	for my $call (@$calls) {
		my $list = $call->parent();
		while ($list && !$list->isa('PPI::Structure::List')) {
			$list = $list->parent;
		}
		if(!defined($list)) {
			my $next = $call->next_sibling();
			my ($arglist, $schema_text) = $self->_parse_pv_call($next);

			if($schema_text) {
				my $compartment = Safe->new();
				$compartment->permit_only(qw(:base_core :base_mem :base_orig));

				my $schema_str = "my \$schema = { $schema_text }";
				$schema_str =~ s/ArrayRef\[(.+?)\]/arrayref, element_type => $1/g;
				my $schema = $compartment->reval($schema_str);

				if(scalar keys %{$schema}) {
					foreach my $arg(keys %{$schema}) {
						my $field = $schema->{$arg};
						if(my $isa = delete $field->{'isa'}) {
							$field->{'type'} = $isa;
						}
						if(exists($field->{'required'})) {
							my $required = delete $field->{'required'};
							$field->{'optional'} = $required ? 0 : 1;
						} else {
							$field->{'optional'} = 1;
						}
						if(ref($field->{'default'}) eq 'CODE') {
							delete $field->{'default'};	# TODO
						}
					}

					foreach my $arg(keys %{$schema}) {
						my $field = $schema->{$arg};
						if(my $type = $field->{'type'}) {
							if($type eq 'ARRAYREF') {
								$field->{'type'} = 'arrayref';
							} elsif($type eq 'SCALAR') {
								$field->{'type'} = 'string';
							}
						}
						delete $field->{'callbacks'};
					}

					return {
						input => $schema,
						style => 'hash',
						source => 'validator'
					}
				}
			}
		}
		next unless $list;

		my ($schema_block) = grep { $_->isa('PPI::Structure::Block') } $list->children;

		next unless $schema_block;

		my $schema = $self->_extract_schema_hash_from_block($schema_block);
		return $self->_normalize_validator_schema($schema) if $schema;
	}

	return;
}

# --------------------------------------------------
# _extract_schema_hash_from_block
#
# Purpose:    Extract a parameter schema hashref from
#             a PPI::Structure::Block node representing
#             the schema argument to a validator call
#             such as validate_strict({ ... }).
#
# Entry:      $block - a PPI::Structure::Block node.
#
# Exit:       Returns a hashref of parameter name to
#             spec hashref, or undef if parsing fails.
#
# Side effects: None.
#
# Notes:      Delegates to _parse_schema_hash which
#             expects a PPI node with a children()
#             method. This method exists to provide
#             a clear semantic name at the call site.
# --------------------------------------------------
sub _extract_schema_hash_from_block {
	my ($self, $block) = @_;

	return unless $block && $block->can('children');

	my $result = $self->_parse_schema_hash($block);

	return unless $result && ref($result) eq 'HASH' && $result->{input};

	return $result->{input};
}

# --------------------------------------------------
# _normalize_validator_schema
#
# Purpose:    Normalise a raw validator schema
#             hashref (as extracted from PPI) into