File Coverage

blib/lib/Business/OnlinePayment/InternetSecure.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::OnlinePayment::InternetSecure;

use 5.008;
use strict;
use warnings;

use Carp;
use Encode;
use Net::SSLeay qw(make_form post_https);
use XML::Simple qw(xml_in xml_out);

use base qw(Business::OnlinePayment Exporter);


our $VERSION = '0.10';


use constant SUCCESS_CODES => qw(2000 90000 900P1);

use constant CARD_TYPES => {
				AM => 'American Express',
				JB => 'JCB',
				MC => 'MasterCard',
				NN => 'Discover',
				VI => 'Visa',
			};


# Convenience functions to avoid undefs and escape products strings
sub _def($) { defined $_[0] ? $_[0] : '' }
sub _esc($) { local $_ = shift; tr/|:/ /s; tr/"`/'/s; return $_ }


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

	$self->server('secure.internetsecure.com');
	$self->port(443);
	$self->path('/process.cgi');

	$self->build_subs(qw(
				receipt_number	order_number	uuid	guid
				date
				card_type	cardholder
				total_amount	tax_amounts
				avs_code	cvv2_response
			));

	# Just in case someone tries to call tax_amounts() *before* submit()
	$self->tax_amounts( {} );
}

# Backwards-compatible support for renamed fields
sub avs_response { shift()->avs_code(@_) }
sub sales_number { shift()->order_number(@_) }


# Combine get_fields and remap_fields for convenience.  Unlike OnlinePayment's
# remap_fields, this doesn't modify content(), and can therefore be called
# more than once.  Also, unlike OnlinePayment's get_fields in 3.x, this doesn't
# exclude undefs.
#
sub get_remap_fields {
	my ($self, %map) = @_;

	my %content = $self->content();
	my %data;

	while (my ($to, $from) = each %map) {
		$data{$to} = $content{$from};
	}

	return %data;
}

# Since there's no standard format for expiration dates, we try to do our best
#
sub parse_expdate {
	my ($self, $str) = @_;

	local $_ = $str;

	my ($y, $m);

	if (/^(\d{4})\W(\d{1,2})$/ ||		# YYYY.MM  or  YYYY-M
			/^(\d\d)\W(\d)$/ ||	# YY/M  or  YY-M
			/^(\d\d)[.-](\d\d)$/) {	# YY-MM
		($y, $m) = ($1, $2);
	} elsif (/^(\d{1,2})\W(\d{4})$/ ||	# MM-YYYY  or  M/YYYY
			/^(\d)\W(\d\d)$/ ||	# M/YY  or  M-YY
			/^(\d\d)\/?(\d\d)$/) {	# MM/YY  or  MMYY
		($y, $m) = ($2, $1);
	} else {
		croak "Unable to parse expiration date: $str";
	}

	$y += 2000 if $y < 2000;  # Aren't we glad Y2K is behind us?

	return ($y, $m);
}

# Convert a single product into a product string
#
sub prod_string {
	my ($self, $currency, %data) = @_;

	croak "Missing amount in product" unless defined $data{amount};

	my @flags = ($currency);

	my @taxes;
	if (ref $data{taxes}) {
		@taxes = @{ $data{taxes} };
	} elsif ($data{taxes}) {
		@taxes = split ' ' => $data{taxes};
	}

	foreach (@taxes) {
		croak "Unknown tax code $_" unless /^(GST|PST|HST)$/i;
		push @flags, uc $_;
	}

	if ($self->test_transaction) {
		push @flags, $self->test_transaction < 0 ? 'TESTD' : 'TEST';
	}

	# recurring can come as string or hashref
	if ($data{recurring}) {
		if (ref $data{recurring}) {
			my @options;
			push @options, 'RB';
			foreach my $key ( sort keys %{ $data{recurring} } ) {
				push @options, $key . '=' . $data{recurring}{$key};
			}
			push @flags, join ' ', @options;
		} else {
			push @flags, "RB $data{recurring}";
		}
	}

	return join '::' =>
				sprintf('%.2f' => $data{amount}),
				$data{quantity} || 1,
				_esc _def $data{sku},
				_esc _def $data{description},
				join('' => map "{$_}" => @flags),
				;
}

# Generate the XML document for this transaction
#
sub to_xml {
	my ($self) = @_;

	my %content = $self->content;

	# Backwards-compatible support for exp_date
	if (exists $content{exp_date} && ! exists $content{expiration}) {
		$content{expiration} = delete $content{exp_date};
		$self->content(%content);
	}

	$self->required_fields(qw(action card_number expiration));

	croak "Unsupported card type: $content{type}"
		if $content{type} &&
			! grep lc($content{type}) eq lc($_),
				values %{+CARD_TYPES}, 'CC';

	croak 'Unsupported action'
		unless $content{action} =~ /^(Normal|Card) Authori[zs]ation$/i;

	$content{currency} = uc($content{currency} || 'CAD');
	croak "Unknown currency code ", $content{currency}
		unless $content{currency} =~ /^(CAD|USD)$/;

	my %data = $self->get_remap_fields(qw(
			xxxCard_Number		card_number

			xxxName			name
			xxxCompany		company
			xxxAddress		address
			xxxCity			city
			xxxProvince		state
			xxxPostal		zip
			xxxCountry		country
			xxxPhone		phone
			xxxEmail		email

			xxxShippingName		ship_name
			xxxShippingCompany	ship_company
			xxxShippingAddress	ship_address
			xxxShippingCity		ship_city
			xxxShippingProvince	ship_state
			xxxShippingPostal	ship_zip
			xxxShippingCountry	ship_country
			xxxShippingPhone	ship_phone
			xxxShippingEmail	ship_email

			xxxCustomerDB		cimb_store
		));

	$data{MerchantNumber} = $self->merchant_id;

	$data{xxxCard_Number} =~ tr/- //d;
	$data{xxxCard_Number} =~ s/^[^3-6]/4/ if $self->test_transaction;

	my ($y, $m) = $self->parse_expdate($content{expiration});
	$data{xxxCCYear} = sprintf '%.4u' => $y;
	$data{xxxCCMonth} = sprintf '%.2u' => $m;

	delete $data{xxxCustomerDB} unless $data{xxxCustomerDB};

	# Recurring
	if (defined $content{recurring} && $content{recurring} ne '') {
		$data{xxxCardInput} = 8;
	}

	if (defined $content{cvv2} && $content{cvv2} ne '') {
		$data{CVV2} = $content{cvv2};
		$data{CVV2Indicator} = 1;
	} else {
		$data{CVV2} = '';
		$data{CVV2Indicator} = 0;
	}

	if ($content{action} =~ /^Card Authori[zs]ation$/i) {
		$data{xxxTransType} = 22;

		$data{Products} = $self->prod_string(
					$content{currency},
					taxes       => 0,
					amount      => 0.0,
					description => 'CardAuth and Store',
				);
	} else {

		if (ref $content{description}) {
			$data{Products} = join '|' => map $self->prod_string(
							$content{currency},
							taxes => $content{taxes},
							%$_),
						@{ $content{description} };
		} else {
			$self->required_fields(qw(amount));
			$data{Products} = $self->prod_string(
						$content{currency},
						taxes       => $content{taxes},
						amount      => $content{amount},
						description => $content{description},
						recurring   => $content{recurring},
					);
		}

	}

	# The encode() makes sure to a) strip off non-Latin-1 characters, and
	# b) turn off the utf8 flag, which confuses XML::Simple
	encode('ISO-8859-1', xml_out(\%data,
		NoAttr		=> 1,
		RootName	=> 'TranxRequest',
		SuppressEmpty	=> undef,
		XMLDecl		=> '',
	));
}

# Map the various fields from the response, and put their values into our
# object for retrieval.
#
sub infuse {
	my ($self, $data, %map) = @_;

	while (my ($k, $v) = each %map) {
		no strict 'refs';
		$self->$k($data->{$v});
	}
}

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

	my %tax_amounts;

	my $products = $response->{Products};
	return unless $products;

	foreach my $node (@$products) {
		my $flags = $node->{flags};
		if ($flags &&
			grep($_ eq '{TAX}', @$flags) &&
			grep($_ eq '{CALCULATED}', @$flags))
		{
			$tax_amounts{ $node->{code} } = $node->{subtotal};
		}
	}

	return %tax_amounts;
}

# Parse the server's response and set various fields
#
sub parse_response {
	my ($self, $response) = @_;

	$self->server_response($response);

	local $/ = "\n";  # Make sure to avoid bug #17687

	$response = xml_in($response,
 			ForceArray => [qw(product flag)],
 			GroupTags => { qw(Products product flags flag) },
 			KeyAttr => [],
 			SuppressEmpty => undef,
		);

	$self->infuse($response,
			result_code	=> 'Page',
			error_message	=> 'Verbiage',
			authorization	=> 'ApprovalCode',
			avs_code	=> 'AVSResponseCode',
			cvv2_response	=> 'CVV2ResponseCode',

			receipt_number	=> 'ReceiptNumber',
			order_number	=> 'SalesOrderNumber',
			uuid		=> 'GUID',
			guid		=> 'GUID',

			date		=> 'Date',
			cardholder	=> 'xxxName',
			card_type	=> 'CardType',
			total_amount	=> 'TotalAmount',
			);

	$self->is_success(scalar grep $self->result_code eq $_, SUCCESS_CODES);

	# Completely undocumented field that sometimes override
	$self->error_message($response->{Error}) if $response->{Error};

	# Delete error_message if transaction was successful
	$self->error_message(undef) if $self->is_success;

	$self->card_type(CARD_TYPES->{$self->card_type});

	$self->tax_amounts( { $self->extract_tax_amounts($response) } );

	return $self;
}

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

	croak "Missing required argument 'merchant_id'"
		unless defined $self->{merchant_id};

	my ($page, $response, %headers) =
		post_https(
				$self->server,
				$self->port,
				$self->path,
				undef,
				make_form(
					xxxRequestMode => 'X',
					xxxRequestData => $self->to_xml,
				)
			);

	croak 'Error connecting to server' unless $page;
	croak 'Server responded, but not in XML' unless $page =~ /^<\?xml/;

	# The response is marked UTF-8, but it's really Latin-1.  Sigh.
	$page =~ s/^(<\?xml.*?) encoding="utf-8"/$1 encoding="iso-8859-1"/si;

	$self->parse_response($page);
}


1;

__END__