view release on metacpan or  search on metacpan

t/lib/Test/Net/SAJAX/UserAgent.pm  view on Meta::CPAN

	return $fake_ua;
}

sub get {
	my ($self, $url) = @_;

	# Get the called function name
	my $function  = $url->query_param('rs');
	my @arguments = $url->query_param('rsargs[]');
	my $target_id = $url->query_param('rst');
	my $rand_key  = $url->query_param('rsrnd');

	# Change URL into a URI object
	$url = URI->new($url);

	return _process_request(
		function  => $function,
		arguments => \@arguments,
		target_id => $target_id,
		rand_key  => $rand_key,
		url       => $url,
		method    => 'GET',
	);
}

sub post {
	my ($self, $url, $post_data) = @_;

	# Get the called function name
	my $function  = $post_data->{rs};
	my $arguments = $post_data->{'rsargs[]'};

	return _process_request(
		function  => $function,
		arguments => $arguments,
		url       => $url,
		method    => 'POST',
	);
}

sub request {
	my ($self, $request) = @_;

	# The function to redirect to
	my $handle_request = sub {
		die sprintf 'Cannot handle %s request', $request->method;
	};

	if ($request->method eq 'GET') {
		# Forward to GET mocker
		$handle_request = sub { return $self->get($request->uri); };
	}
	elsif ($request->method eq 'POST') {
		# Forward to POST mocket
		$handle_request = sub {
			# Get the key pairs from the content
			my %content = map {
				URI::Escape::uri_unescape($_)
			} map {
				split m{=}msx
			} split m{&}msx, $request->decoded_content;

			return $self->post($request->uri, \%content);
		};
	}

	# Forward the request
	return $handle_request->();
}

sub _process_request {
	my %args = @_;

	my ($function, $method) = @args{qw(function method)};

	my $call = __PACKAGE__->can("_any_$function");

	if (!defined $call) {
		if ($method eq 'POST') {
			$call = __PACKAGE__->can("_post_$function");
		}
		else {
			$call = __PACKAGE__->can("_get_$function");
		}
	}

	if (!defined $call) {
		return HTTP::Response->new(200, 'OK', undef, "-:$function not callable");
	}

	my $data = eval { $call->(%args) };

	if ($@) {
		return HTTP::Response->new(200, 'OK', undef, "-:Perl error occurred: $@");
	}

	if (ref $data ne 'HASH') {
		return HTTP::Response->new(200, 'OK', undef, sprintf '+:%s', $data);
	}
	elsif (!exists $data->{response}) {
		return HTTP::Response->new(200, 'OK', undef, sprintf '+:%s', $data->{data});
	}

	return $data->{response};
}


sub _any_Echo {
	my %args = @_;

	my @arguments = @{$args{arguments}};

	if (!@arguments) {
		die 'Nothing supplied to Echo';
	}

	return {
		response => HTTP::Response->new(200, 'OK', undef, $arguments[0]),
	};
}
sub _any_EchoRandKey {