view release on metacpan or  search on metacpan

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

package Business::WebMoney;

use 5.008000;
use strict;
use warnings;
use utf8;

our $VERSION = '0.11';

use Carp;
use LWP::UserAgent;
use XML::LibXML;
use HTTP::Request;
use File::Spec;
use POSIX();

sub new
{
	my ($class, @args) = @_;

	my $opt = parse_args(\@args, {
		p12_file => 'mandatory',
		p12_pass => undef,
		timeout => 20,
		ca_file => undef,
	});

	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 {

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

	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;
			$req->method('POST');
			$req->uri("https://w3s.wmtransfer.com/asp/XML$args{func}Cert.asp");
			$req->content($req_data);

			my ($res, $timeout);

			eval {
				local $SIG{__DIE__};
				local $SIG{ALRM} = sub {
					$timeout = 1;
				};

				alarm($self->{timeout});
				$res = $ua->request($req);
				alarm(0);
			};

			if ($timeout) {

				$self->{errcode} = -1001;
				$self->{errstr} = 'Connection timeout';
				return undef;

			} elsif (!$res->is_success) {

				$self->{errcode} = $res->code;
				$self->{errstr} = $res->message;
				return undef;
			}

			$res_content = $res->content;
		}

		my $parser = XML::LibXML->new;

		my $doc = $parser->parse_string($res_content);

		if (my $retval = $doc->findvalue('/w3s.response/retval')) {

			$self->{errcode} = $retval;
			$self->{errstr} = $doc->findvalue('/w3s.response/retdesc');
			return undef;
		}

		my ($result_node) = $doc->getElementsByTagName($args{result_tag});

		if ($args{result_format} eq 'list') {

			[ map { result_node($_) } grep { $_->isa('XML::LibXML::Element') } $result_node->childNodes ];

		} elsif ($args{result_format} eq 'hash') {

			result_node($result_node);

		} else {

			1;
		}
	};