File Coverage

blib/lib/Business/CanadaPost.pm

Criterion	Covered	Total	%
statement	12	192	6.2
branch	0	76	0.0
condition	0	101	0.0
subroutine	4	36	11.1
pod	26	29	89.6
total	42	434	9.6

package Business::CanadaPost;
our $AUTHORITY = 'cpan:YANICK';
# ABSTRACT: Fetch shipping costs for Canada Post (DEPRECATED)
$Business::CanadaPost::VERSION = '1.07';
use strict;
use LWP;
use vars qw($VERSION @ISA @EXPORT);
use Exporter;

@ISA		= qw(Exporter);
@EXPORT		= qw();


sub new # {{{
{
	my ($class, %data) = @_;

	my $self = {
		language	=> 'en',	#canada post supports english (en) and french (fr)
		frompostalcode	=> '',		#canada post says to send a space if we have no entry...
		turnaroundtime  => '',
		merchantid	=> '',
		totalprice	=> '0.00',
		units		=> 'metric',	#allows for metric (cm and kg) or imperial (in and lb) measurements.
		items		=> [],
		testing		=> 0
	};

	foreach (keys %data)
	{
		$self->{$_} = $data{$_};
	}

	bless $self, $class;

	return $self;
} # }}}


sub geterror # {{{
{
	my $self = shift;
	my $error = $self->{'error'};
	$self->{'error'} = ''; #clear it once we've sent it.
	return $error;
} # }}}

sub setlanguage # {{{
{
	my ($self, $lang) = @_;

	$lang = lc($lang);
	return $self->_error(4) unless $lang eq 'fr' or $lang eq 'en' or $lang eq '';

	$self->{'language'} = $lang || 'en';
} # }}}


sub settocity # {{{

{
	my ($self, $city) = @_;
	$self->{'city'} = $city;
} # }}}


sub settesting # {{{

{
	my ($self, $testing) = @_;

	$self->{'testing'} = $testing;
} # }}}


sub setcountry # {{{

{
	my ($self, $country) = @_;
	$self->{'country'} = $country;
} # }}}


sub setmerchantid # {{{

{
	my ($self, $id) = @_;

	$self->{'merchantid'} = $id || ' ';
} # }}}


sub setunits # {{{

{
	my ($self, $units) = @_;

#FIXME -- make it go through each item and convert to/from metric if they change!
	$units = lc($units);
	return $self->_error(5) unless $units eq 'metric' or $units eq 'imperial';
	$self->{'units'} = $units;
} # }}}


sub setfrompostalcode # {{{

{
	my ($self, $code) = @_;

	$self->{'frompostalcode'} = $code || ' ';
} # }}}


sub settopostalzip # {{{

{
	my ($self, $code) = @_;

	$self->{'postalcode'} = $code || ' ';
} # }}}


sub setprovstate # {{{

{
	my ($self, $province) = @_;
	$self->{'provstate'} = $province || ' ';
} # }}}


sub setturnaroundtime # {{{

{
	my ($self, $code) = @_;
	$self->{'turnaroundtime'} = $code || ' ';
} # }}}


sub settotalprice # {{{

{
	my ($self, $price) = @_;
	$self->{'totalprice'} = sprintf('%01.2f', $price) || '0.00';
} # }}}


sub additem # {{{
{
	my ($self, %item) = @_;

	$item{'length'} and $item{'width'} and $item{'height'} or
		return $self->_error(6);

	my @currentitems = @{$self->{'items'}} if ref $self->{'items'};

	#canadapost specifies that the longest dimension is the length,
	#second longest is the width and shortest is height.
	my @dimensions = ($item{'length'}, $item{'height'}, $item{'width'});
	($item{'length'}, $item{'width'}, $item{'height'}) = reverse sort @dimensions;

	my $metric = $self->{'units'} eq 'imperial' ? 0 : 1;

	push (@currentitems, $item{'quantity'} || 1,
				$metric ? $item{'weight'} : $item{'weight'} * .45359237, # 1lb = .45359237kg
				$metric ? $item{'length'} : $item{'length'} * 2.54,	 # 1in = 2.54cm
				$metric ? $item{'width'}  : $item{'width'}  * 2.54,
				$metric ? $item{'height'} : $item{'height'} * 2.54,
				$item{'description'} || ' ',
				$item{'readytoship'} ? '' : '');

	$self->{'items'} = \@currentitems;
} # }}}


sub getrequest # {{{
{
	my $self = shift;
	my $xmlfile = $self->buildXML() or return $self->_error($self->{'error'});

	my $lwp = LWP::UserAgent->new();
	my $result = $lwp->post("http://sellonline.canadapost.ca:30000", { 'XMLRequest' => $xmlfile });
	return $self->_error(8) unless $result->is_success;

	my $raw_data = $result->content();

	return $self->parseXML($raw_data);
} # }}}

sub parseXML # {{{

{
	my ($self, $xml) = @_;

	my ($parcel) = $xml =~ /(.+)<\/eparcel>/s;
	my ($resultcode) = $parcel =~ /([^<]+)<\/statusCode>/s;
	unless ($resultcode == 1)
	{
		my ($resultmessage) = $parcel =~ /([^<]+)<\/statusMessage>/s;
		return $self->_error($resultmessage);
	}
	my ($products) = $parcel =~ //s; #should be greedy and get them all..
	my @options;
	foreach my $product (split /<\/product>\s+
	{
		my ($name)	= $product =~ /([^<]+)<\/name>/s;
		my ($rate)	= $product =~ /([^<]+)<\/rate>/s;
		my ($shipdate)	= $product =~ /([^<]+)<\/shippingDate>/s;
		my ($delvdate)	= $product =~ /([^<]+)<\/deliveryDate>/s;
		my ($dayofweek)	= $product =~ /([^<]+)<\/deliveryDayOfWeek>/s;
		my ($nextdayam)	= $product =~ /([^<]+)<\/nextDayAM>/s;
		my $estdays     = _getdaysbetween($shipdate, $delvdate);
		$estdays = 'Unknown' if $estdays == -1;
		$nextdayam = $nextdayam eq 'true' ? 1 : 0;
		push (@options, $name, $rate, $shipdate, $delvdate, $dayofweek, $nextdayam, $estdays);
	}

	$self->{'shippingoptioncount'} = scalar(@options) / 7;
	$self->{'shiprates'} = \@options;

	my ($soptions) = $parcel =~ /(.+)<\/shippingOptions>/s;
	if ($soptions =~ /([^<]+)<\/insurance>/)
	{
		$self->{'shipinsurance'} = $1 eq 'No' ? 0 : 1;
	}
	if ($soptions =~ /([^<]+)<\/deliveryConfirmation>/)
	{
		$self->{'shipconfirm'} = $1 eq 'No' ? 0 : 1;
	}
	if ($soptions =~ /([^<]+)<\/signature>/)
	{
		$self->{'signature'} = $1 eq 'No' ? 0 : 1;
	}

	$self->{'shipcomments'} = $1 if $parcel =~ /([^<]+)<\/comment>/s;
	return 1;
} # }}}


sub getoptioncount # {{{
{
	my $self = shift;
	return $self->{'shippingoptioncount'};
} # }}}



sub getsignature # {{{

{
	my $self = shift;
	return $self->{'signature'};
} # }}}


sub getinsurance # {{{

{
	my $self = shift;
	return $self->{'shipinsurance'};
} # }}}



sub getshipname # {{{

{
	my $self = shift;
	my $shipmentnum = shift || 1;
	$shipmentnum--; #we're looking for the offset in the array...

	my @options = @{$self->{'shiprates'}};
	return $options[$shipmentnum * 7]
} # }}}


sub getshiprate # {{{

{
	my $self = shift;
	my $shipmentnum = shift || 1;
	$shipmentnum--;
	my @options = @{$self->{'shiprates'}};
	return $options[$shipmentnum * 7 + 1]
} # }}}



sub getshipdate # {{{

{
	my $self = shift;
	my $shipmentnum = shift || 1;
	$shipmentnum--;
	my @options = @{$self->{'shiprates'}};
	return $options[$shipmentnum * 7 + 2]
} # }}}


sub getdelvdate # {{{

{
	my $self = shift;
	my $shipmentnum = shift || 1;
	$shipmentnum--;
	my @options = @{$self->{'shiprates'}};
	return $options[$shipmentnum * 7 + 3]
} # }}}



sub getdayofweek # {{{

{
	my $self = shift;
	my $shipmentnum = shift || 1;
	$shipmentnum--;
	my @options = @{$self->{'shiprates'}};
	return $options[$shipmentnum * 7 + 4]
} # }}}



sub getnextdayam # {{{

{
	my $self = shift;
	my $shipmentnum = shift || 1;
	$shipmentnum--;
	my @options = @{$self->{'shiprates'}};
	return $options[$shipmentnum * 7 + 5]
} # }}}



sub getestshipdays # {{{

{
	my $self = shift;
	my $shipmentnum = shift || 1;
	$shipmentnum--;
	my @options = @{$self->{'shiprates'}};
	return $options[$shipmentnum * 7 + 6]
} # }}}



sub getconfirmation # {{{

{
	my $self = shift;
	return $self->{'shipconfirm'};
} # }}}


sub getcomments # {{{

{
	my $self = shift;
	return $self->{'shipcomments'};
} # }}}

sub _error # {{{

{
	my ($self, $msgnum) = @_;
	my @englishmessages = ('You need to specify some items to ship!',
				'You must specify a valid postal code for Canadian shipments!',
				'You must specify a state for American shipments!',
				'You must specify the country being shipped to!',
				'Valid languages are English and French',
				'Valid units are metric (cm and kg) or imperial (in and lb)',
				'You must specify a height, width, and length for each item.',
				'You must specify your Canada Post merchant ID!',
				'Failed sending to Canada Posts servers!');
	my @frenchmessages  = ('Vous devez indiquer quelques pour transporter!',
				'Vous devez indiquer un code postal valide pour les expéditions Canadiannes!',
				'Vous devez indiquer un état pour les expéditions américaines!',
				'Vous devez indiquer le pays que vous voulez embarquer à!',
				'Les langues valides sont Anglaises et Françaises',
				'Les unités valides sont métriques (cm et kg) ou impériales (po et lv)',
				'Vous devez indiquer une taille, une largeur, et une longueur pour chaque article.',
				'Vous devez indiquer votre identification du Postes Canada!',
				'Envoi échoué aux serveurs du Postes Canada!');

	if ($msgnum == 0)
	{
		push (@englishmessages, $msgnum);
		push (@frenchmessages, $msgnum);
		$msgnum = scalar(@englishmessages) - 1;
	}

	$self->{'error'} = sprintf("%s\n",
			$self->{'language'} eq 'fr' ? $frenchmessages[$msgnum] :
							$englishmessages[$msgnum]);
	return 0;
} # }}}

sub _getdaysbetween # {{{

{
	my ($fromdate, $todate) = @_;
	my @daysinmonth = (0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);

	my ($fromyear, $frommon, $fromday) = split /-/, $fromdate;
	my ($toyear, $tomon, $today) = split /-/, $todate;

	return 0 if $fromyear == $toyear and $frommon == $tomon and $fromday == $today;
	return -1 unless $fromyear and $frommon and $fromday and $toyear and $tomon and $today;

	my $days;

	do
	{
		$days++;
		$fromday++;
		$daysinmonth[2] = _isleapyear($fromyear) ? 29 : 28;
		$fromday = 1, $frommon++ if $fromday > $daysinmonth[$frommon];
		$frommon = 1, $fromyear++ if $frommon == 13;
	} until $fromyear == $toyear and $frommon == $tomon and $fromday == $today;

	return $days;
} # }}}

sub _isleapyear # {{{

{
	my $year = shift;

        return 1 if $year % 4 == 0 and $year % 400 == 0;
        return 0 if $year % 100 == 0;
        return 1 if $year % 4 == 0;
        return 0;
} # }}}

sub buildXML # {{{

{
	my $self = shift;

	my @items = @{$self->{'items'}};
	return $self->_error(0) unless @items;

	# language can be en or fr (this is Canada!)
	my $xmlfile = sprintf('

	%s

		%s
		%s
		%s
		%.2f%s',
		$self->{'language'} || 'en',
		$self->{'merchantid'} || return $self->_error(7),
		$self->{'frompostalcode'} ? "" . $self->{'frompostalcode'} . "\n" : '',
		$self->{'turnaroundtime'} ? "" . $self->{'turnaroundtime'} . "\n" : '',
		$self->{'totalprice'} || '0.00',
	   	"\n");


	$xmlfile .= "		\n";
	for (my $n = 0; $n < @items; $n += 7)
	{
		$xmlfile .= sprintf("
				%d
				%01.2f
				%01.2f
				%01.2f
				%01.2f
				%s
				%s
			\n",
			@items[$n .. $n+6]);
	}
	$xmlfile .= "		\n";

	if (!$self->{'country'} or $self->{'country'} =~ /^\s*$/) # no country specified...
	{
		return $self->_error(3);
	}
	elsif (uc($self->{'country'}) eq 'CANADA' or uc($self->{'country'}) eq 'CA')
	{
		#canada post docs state that only postal code must exist for canadian shipments
		$self->{'postalcode'} =~ s/[^\d\w]//g;
		$self->{'postalcode'} =~ /^\w\d\w\d\w\d$/
			or return $self->_error(1);

	}
	elsif (uc($self->{'country'}) eq 'UNITED STATES' or uc($self->{'country'} eq 'US')
			or uc($self->{'country'}) eq 'ÉTATS-UNIS')
	{
		#canada post says that all they require for now is country and provorstate; however,
		#zipcodes will be used in the future...
		$self->{'provstate'} or return $self->_error(2);
		$self->{'postalcode'} ||= ' ';
		$self->{'postalcode'} =~ s/\D//g;
	}

	$xmlfile .= sprintf("		%s
		%s
		%s
		%s

",
	$self->{'city'} || ' ',
	$self->{'provstate'} || ' ',
	$self->{'country'},
	$self->{'postalcode'} || ' ');

	return $xmlfile;
} # }}}

1;

__END__