view release on metacpan or  search on metacpan

lib/Business/WebMoney.pm  view on Meta::CPAN

	});

	my $ca_file = $opt->{ca_file};
	$ca_file or ($ca_file) = grep(-r $_, map(File::Spec->catdir($_, qw(Business WebMoney WebMoneyCA.crt)), @INC));
	$ca_file or warn "Business/WebMoney/WebMoneyCA.crt missing";

	my $self = {
		p12_file => $opt->{p12_file},
		p12_pass => $opt->{p12_pass},
		timeout => $opt->{timeout},
		ca_file => $ca_file,
	};

	return bless $self, $class;
}

sub parse_args
{
	my ($args_list, $fields) = @_;

	if (@$args_list % 2) {

		croak 'Unpaired arguments';
	}

	my %args;

	while (@$args_list) {

		my $key = shift @$args_list;
		my $value = shift @$args_list;

		exists($fields->{$key}) or croak "Unknown argument $key";
		exists($args{$key}) and croak "Argument $key specified multiple times";

		$args{$key} = $value;
	}

	while (my ($key, $value) = each(%$fields)) {

		unless (exists($args{$key})) {

			if ($value && $value eq 'mandatory') {

				croak "Mandatory argument $key not specified";

			} else {

				$args{$key} = $value;
			}
		}
	}

	return \%args;
}

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

	my $old_locale = POSIX::setlocale(&POSIX::LC_ALL, 'C');

	my $res = $self->do_request(%args);

	POSIX::setlocale(&POSIX::LC_ALL, $old_locale);

	return $res;
}

sub do_request
{
	my ($self, %args) = @_;

	$self->{errstr} = undef;
	$self->{errcode} = undef;

	my $req_fields = parse_args($args{args}, { %{$args{arg_rules}}, debug_response => undef });

	my $doc = XML::LibXML::Document->new('1.0', 'UTF-8');

	my $request = $doc->createElement('w3s.request');
	$doc->setDocumentElement($request);

	my $node = $doc->createElement('reqn');
	$request->appendChild($node);
	$node->appendChild($doc->createTextNode($req_fields->{reqn}));
	delete $req_fields->{reqn};

	my $data_node = $doc->createElement($args{req_tagname});
	$request->appendChild($data_node);

	while (my ($key, $value) = each %$req_fields) {

		next unless defined $value;
		next if $key eq 'debug_response';

		my $node = $doc->createElement($key);
		$data_node->appendChild($node);
		$node->appendChild($doc->createTextNode($value));
	}

	my $res = eval {

		local $SIG{__DIE__};
       
		# Warning! Thread unsafe!

		local %ENV = %ENV;

		$ENV{HTTPS_PKCS12_FILE} = $self->{p12_file};
		$ENV{HTTPS_PKCS12_PASSWORD} = $self->{p12_pass};
		$ENV{HTTPS_CA_FILE} = $self->{ca_file};

		my $req_data = $doc->serialize;

		utf8::encode($req_data) if utf8::is_utf8($req_data);

		my $res_content;

		unless ($res_content = $req_fields->{debug_response}) {

			my $ua = LWP::UserAgent->new;
			$ua->timeout($self->{timeout} + 1);

			my $req = HTTP::Request->new;