Net::SAJAX - Interact with remote applications that use SAJAX.

  # Construct a SAJAX interaction object
  my $sajax = Net::SAJAX->new(
    url => URI->new('https:/www.example.net/my_sajax_app.php'),
  );

  # Make a SAJAX call
  my $product_name = $sajax->call(
    function  => 'GetProductName',
    arguments => [67632],
  );

  print "The product $product_name is out of stock\n";

  # Make a SAJAX call using POST (usually for big or sensitive data)
  my $result = $sajax->call(
    function  => 'SetPassword',
    method    => 'POST',
    arguments => ['My4w3s0m3p4sSwOrD'],
  );

  if ($result->{result} == 1) {
    print "Your password was successfully changed\n";
  }
  else {
    printf "An error occurred when setting your password: %s\n",
      $result->{error_message};
  }

  # Enable sending of a random key
  $sajax->send_rand_key(1);

  # Toggle the setting
  $sajax->send_rand_key(!$sajax->send_rand_key());

  # Change the target ID
  $sajax->target_id('content');

  # Clear the target ID (restoring default behavior)
  $sajax->clear_target_id();

  # Set a low timeout value
  $sajax->user_agent->timeout(10);

  # call may return an ARRAYREF for an array
  my $array_ref = $sajax->call(function => 'IReturnAnArray');
  print 'Returned: ', join q{,}, @{$array_ref};

  # call may return a HASHREF for an object
  my $hash_ref = $sajax->call(function => 'IReturnAnObject');
  print 'Error value: ', $hash_ref->{error};

  # There may even be a property of an object that is an array
  my $object = $sajax->call(function => 'GetProductInfo');
  printf "Product: %s\nPrices: %s\n",
    $object->{name},
    join q{, }, @{$object->{prices}};

  perldoc Net::SAJAX

package Net::SAJAX;

use 5.008003;
use strict;
use warnings 'all';

###############################################################################
# METADATA
our $AUTHORITY = 'cpan:DOUGDUDE';
our $VERSION   = '0.106';

###############################################################################
# MOOSE
use Moose 0.77;
use MooseX::StrictConstructor 0.08;

###############################################################################
# MOOSE TYPES
use MooseX::Types::URI 0.02 qw(Uri);

###############################################################################
# MODULE IMPORTS
use Carp qw(croak);
use English qw(-no_match_vars);
use HTTP::Request::Common 5.814 (); # No imports
use JE 0.033;
use List::MoreUtils qw(any);
use LWP::UserAgent 5.819;
use Net::SAJAX::Exception 0.103;
use URI 1.22;
use URI::QueryParam;

###############################################################################
# ALL IMPORTS BEFORE THIS WILL BE ERASED
use namespace::clean 0.04 -except => [qw(meta)];

###############################################################################
# ATTRIBUTES
has autoclean_garbage => (
	is            => 'rw',
	isa           => 'Bool',
	default       => 0,
	documentation => q{Whether or not to try automatic cleaning of garbage in the response},
);
has javascript_engine => (
	is            => 'ro',
	isa           => 'JE',
	default       => sub { JE->new(max_ops => 1000) },
	documentation => q{JE object used for executing returned JavaScript},
);
has send_rand_key => (
	is            => 'rw',
	isa           => 'Bool',
	default       => 0,
	documentation => q{Whether or not to send a random key with the request},
);
has target_id => (
	is            => 'rw',
	isa           => 'Str',
	clearer       => 'clear_target_id',
	predicate     => 'has_target_id',
	documentation => q{The target ID to send with the request},
);
has url => (
	is            => 'rw',
	isa           => Uri,
	coerce        => 1,
	required      => 1,
	documentation => q{The URL to send the request to},
);
has user_agent => (
	is            => 'rw',
	isa           => 'LWP::UserAgent',
	default       => sub { LWP::UserAgent->new },
	documentation => q{The user agent that will be used to make the requests},
);

###############################################################################
# METHODS
sub call {
	my ($self, %args) = @_;

	# Build a request object
	my $request = $self->_build_request_for_call(%args);

	# Get a response
	my $response = $self->user_agent->request($request);

	if (!$response->is_success) {
		# The response was not successful
		Net::SAJAX::Exception->throw(
			class    => 'Response',
			message  => 'An error occurred in the response',
			response => $response,
		);
	}

	# Get the status and data from the response
	my ($status, $data) = $self->_parse_data_from_response($response);

	if ($status eq q{-}) {
		# This is an error
		Net::SAJAX::Exception->throw(
			class   => 'RemoteError',
			message => $data,
		);
	}

	# Evaluate the data
	my $je_object = $self->javascript_engine->eval($data);

	if ($EVAL_ERROR) {
		# JavaScript error when running code
		Net::SAJAX::Exception->throw(
			class             => 'JavaScriptEvaluation',
			javascript_error  => $EVAL_ERROR,
			javascript_string => $data,
			message           => 'JavaScript error occurred while running code',
		);
	}

	# Get the perl data structure
	my $perl_ref = eval { $self->_unwrap_je_object($je_object) };

	if ($EVAL_ERROR) {
		# An error occurred while expanding the JavaScript structure.
		if (blessed $EVAL_ERROR eq 'Net::SAJAX::Exception::JavaScriptConversion') {
			# Rethrow the error but with the over all JE object
			Net::SAJAX::Exception->throw(
				class             => 'JavaScriptConversion',
				javascript_object => $data,
				message           => 'Failed converting JavaScript object to Perl',
			);
		}
		else {
			croak $EVAL_ERROR;
		}
	}

	return $perl_ref;
}

###############################################################################
# PRIVATE METHODS
sub _build_request_for_call {
	my ($self, %args) = @_;

	# Splice out the variables
	my ($function, $arguments, $method)
		= @args{qw(function arguments method)};

	# Set the default value for method. Perl 5.8 doesn't know //=
	$method ||= 'GET';

	if (!defined $function) {
		# No function was specified
		Net::SAJAX::Exception->throw(
			class          => 'MethodArguments',
			argument       => 'function',
			argument_value => $function,
			message        => 'No function was specified to call',
			method         => 'build_request_for_call',
		);
	}

	# Change the method to uppercase
	$method = uc $method;

	if ($method ne 'GET' && $method ne 'POST') {
		# SAJAX only supports GET and POST
		Net::SAJAX::Exception->throw(
			class          => 'MethodArguments',
			argument       => 'method',
			argument_value => $method,
			message        => 'SAJAX only supports the GET and POST methods',
			method         => 'build_request_for_call',
		);
	}

	if (defined $arguments) {
		if (ref $arguments ne 'ARRAY') {
			# Arguments must refer to an ARRAYREF
			Net::SAJAX::Exception->throw(
				class          => 'MethodArguments',
				argument       => 'arguments',
				argument_value => $arguments,
				message        => 'Must pass arguments as an ARRAYREF',
				method         => 'build_request_for_call',
			);
		}

		if(any {ref $_ ne q{}} @{$arguments}) {
			# No argument can be a reference
			Net::SAJAX::Exception->throw(
				class          => 'MethodArguments',
				argument       => 'arguments',
				argument_value => $arguments,
				message        => 'No arguments can be a reference',
				method         => 'build_request_for_call',
			);
		}
	}

	# Clone the URL
	my $call_url = $self->url->clone;

	# Build the SAJAX arguments
	my %sajax_arguments = (rs => $function);

	if ($self->has_target_id) {
		# Add the target ID
		$sajax_arguments{rst} = $self->target_id;
	}

	if ($self->send_rand_key) {
		# Add in a random key to the request
		$sajax_arguments{rsrnd} = scalar time;
	}

	if (defined $arguments) {
		# Add the arguments to the request
		$sajax_arguments{'rsargs[]'} = $arguments;
	}

	# Hold the request
	my $request;

	if ($method eq 'GET') {
		# Add the SAJAX arguments to the URL for a GET request
		$call_url->query_form_hash(%{$call_url->query_form_hash}, %sajax_arguments, );

		# Make the GET request
		$request = HTTP::Request::Common::GET($call_url);
	}
	else {
		# Make the POST request
		$request = HTTP::Request::Common::POST($call_url, \%sajax_arguments);
	}

	# Return the request
	return $request;
}
sub _parse_data_from_response {
	my ($self, $response) = @_;

	# Copy the content for manipulation
	my $content = $response->content;

	if ($self->autoclean_garbage) {
		# Clean out garbage found at the beginning
		if ($content =~ m{^ \s* ([+-] : .*) \z}msx) {
			$content = $1;
		}

		# For the PHP SAJAX, attempt to parse out the exact response
		if ($content =~ m{([+-] : var \s res \s? = \s? .*? ; \s? res;)}msx) {
			$content = $1;
		}
	}

	# Parse out the status and data from the content
	my ($status, $data) = $content
		=~ m{\A \s* (.) . (.*?) \s* \z}msx;

	if (!defined $status) {
		# The response was bad
		Net::SAJAX::Exception->throw(
			class    => 'Response',
			message  => 'Received a bad response',
			response => $response,
		);
	}

	# Return the status and data as an array
	return ($status, $data);
}
sub _unwrap_je_object {
	my ($self, $je_object) = @_;

	# Specify the HASH that maps object types with a subroutine that will
	# convert the object into a Perl scalar.
	my %object_value_map = (
		'JE::Boolean'   => sub { return shift->value },
		'JE::LValue'    => sub { return $self->_unwrap_je_object(shift->get) },
		'JE::Null'      => sub { return shift->value },
		'JE::Number'    => sub { return shift->value },
		'JE::String'    => sub { return shift->value },
		'JE::Undefined' => sub { return shift->value },
		'JE::Object'    => sub {
			my $hash_ref = shift->value;

			# Iterate through each HASH element and unwrap the value
			foreach my $key (keys %{$hash_ref}) {
				$hash_ref->{$key} = $self->_unwrap_je_object($hash_ref->{$key});
			}

			return $hash_ref;
		},
		'JE::Object::Array'  => sub {
			return [ map { $self->_unwrap_je_object($_) } @{shift->value} ];
		},
		'JE::Object::Boolean' => sub { return shift->value },
		'JE::Object::Date'    => sub { return "$_[0]" },
		'JE::Object::Number'  => sub { return shift->value },
		'JE::Object::RegExp'  => sub { return shift->value },
		'JE::Object::String'  => sub { return shift->value },
	);

	# Get the code reference for converting the object
	my $convert_coderef = $object_value_map{ref $je_object};

	if (!defined $convert_coderef) {
		Net::SAJAX::Exception->throw(
			class             => 'JavaScriptConversion',
			javascript_object => $je_object,
			message           => 'Failed converting JavaScript object to Perl',
		);
	}

	return $convert_coderef->($je_object);
}

###############################################################################
# MAKE MOOSE OBJECT IMMUTABLE
__PACKAGE__->meta->make_immutable;

1;

__END__