File Coverage

blib/lib/Business/WebMoney.pm

Criterion	Covered	Total	%
statement	19	21	90.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	26	28	92.8

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 {

				$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;
			$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;
		}
	};

	if ($@) {

		$self->{errcode} = -1000;
		$self->{errstr} = $@;
		return undef;
	}

	return $res;
}

sub errcode
{
	my ($self) = @_;

	return $self->{errcode};
}

sub errstr
{
	my ($self) = @_;

	return $self->{errstr};
}

sub result_node
{
	my ($node) = @_;

	my %result;

	for my $attr ($node->attributes) {

		my $key = $attr->name;

		$result{$key} = $attr->value;
	}

	for my $child (grep { $_->isa('XML::LibXML::Element') } $node->childNodes) {

		my $key = $child->nodeName;

		$result{$key} = $child->textContent;
	}

	return \%result;
}

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

	return $self->request(
		func => 'Operations',
		args => \@args,
		arg_rules => {
			reqn => 'mandatory',
			purse => 'mandatory',
			wmtranid => undef,
			tranid => undef,
			wminvid => undef,
			orderid => undef,
			datestart => 'mandatory',
			datefinish => 'mandatory',
		},
		req_tagname => 'getoperations',
		result_format => 'list',
		result_tag => 'operations',
	);
}

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

	return $self->request(
		func => 'Invoice',
		args => \@args,
		arg_rules => {
			reqn => 'mandatory',
			orderid => 'mandatory',
			customerwmid => 'mandatory',
			storepurse => 'mandatory',
			amount => 'mandatory',
			desc => 'mandatory',
			address => '',
			period => '0',
			expiration => '0',
		},
		req_tagname => 'invoice',
		result_format => 'hash',
		result_tag => 'invoice',
	);
}

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

	return $self->request(
		func => 'OutInvoices',
		args => \@args,
		arg_rules => {
			reqn => 'mandatory',
			purse => 'mandatory',
			wminvid => undef,
			orderid => undef,
			datestart => 'mandatory',
			datefinish => 'mandatory',
		},
		req_tagname => 'getoutinvoices',
		result_format => 'list',
		result_tag => 'outinvoices',
	);
}

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

	return $self->request(
		func => 'InInvoices',
		args => \@args,
		arg_rules => {
			reqn => 'mandatory',
			wmid => 'mandatory',
			wminvid => undef,
			datestart => 'mandatory',
			datefinish => 'mandatory',
		},
		req_tagname => 'getininvoices',
		result_format => 'list',
		result_tag => 'ininvoices',
	);
}

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

	return $self->request(
		func => 'RejectProtect',
		args => \@args,
		arg_rules => {
			reqn => 'mandatory',
			wmtranid => 'mandatory',
		},
		req_tagname => 'rejectprotect',
		result_format => 'hash',
		result_tag => 'operation',
	);
}

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

	return $self->request(
		func => 'FinishProtect',
		args => \@args,
		arg_rules => {
			reqn => 'mandatory',
			wmtranid => 'mandatory',
			pcode => 'mandatory',
		},
		req_tagname => 'finishprotect',
		result_format => 'hash',
		result_tag => 'operation',
	);
}

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

	return $self->request(
		func => 'SendMsg',
		args => \@args,
		arg_rules => {
			reqn => 'mandatory',
			receiverwmid => 'mandatory',
			msgsubj => 'mandatory',
			msgtext => 'mandatory',
		},
		req_tagname => 'message',
		result_format => 'hash',
		result_tag => 'message',
	);
}

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

	return $self->request(
		func => 'Purses',
		args => \@args,
		arg_rules => {
			reqn => 'mandatory',
			wmid => 'mandatory',
		},
		req_tagname => 'getpurses',
		result_format => 'list',
		result_tag => 'purses',
	);
}

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

	return $self->request(
		func => 'TransMoneyback',
		args => \@args,
		arg_rules => {
			reqn => 'mandatory',
			inwmtranid => 'mandatory',
			amount => 'mandatory',
		},
		req_tagname => 'trans',
		result_format => 'hash',
		result_tag => 'operation',
	);
}

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

	return $self->request(
		func => 'Trans',
	       	args => \@args,
		arg_rules => {
			reqn => 'mandatory',
			tranid => 'mandatory',
			pursesrc => 'mandatory',
			pursedest => 'mandatory',
			amount => 'mandatory',
			period => 0,
			pcode => undef,
			desc => 'mandatory',
			wminvid => 0,
		},
		req_tagname => 'trans',
		result_format => 'hash',
		result_tag => 'operation',
	);
}

1;

__END__