Business::CanadaPost - A module to fetch shipping costs for Canada Post.

	use Business::CanadaPost;

	#initialise object - specifying from postal code, and canada post merchant id
	my $shiprequest = Business::CanadaPost->new(	merchantid => 'CPC_DEMO_XML',
							frompostal => 'M1P1C0',
							testing	   => 1			);

	# add an item to be shipped
	$shiprequest->additem(quantity 		=> 1,
				height 		=> 60,
				width  		=> 15,
				length 		=> 60,
				weight 		=> 7,
				description 	=> 'box o stuff',
				readytoship 	=> 1);

	# set more parameters on the item being shipped
	$shiprequest->setcountry('United States');
	$shiprequest->setprovstate('New York');
	$shiprequest->settopostalzip('11726');
	$shiprequest->settocity('New York');
	$shiprequest->getrequest() || print "Failed sending request: " . $shiprequest->geterror() . "\n"; 
	print "There are " . $shiprequest->getoptioncount() . " available shipping methods.\n";

	$object->getrequest or print "Error: " . $object->geterror() . "\n";

	$object->setlanguage('fr'); # changes messages to french.

	$object->settocity('New York');

	$object->settesting(1);

	$object->setcountry('United States');

	$object->setmerchantid('CPC_DEMO_XML');

	$object->setunits('imperial');

	$object->setfrompostalcode(''); # will reset postal code back to default set in canada post profile

	$object->settopostalcode('N2G5M4');

	$object->settopostalcode('Ontario');

	$object->setturnaroundtime(24);

	$object->settotalprice(5.50);

	$object->additem(length => 5,
			 height => 3,
			 width  => 2,
			 weight => 5,
			 description => "box of cookies",
			 readytoship => 1,
			 quantity => 1);

	$object->getrequest();

	my $available_options = $object->getoptioncount();

	my $signature_required = $object->getsignature();

	my $insurance_included = $object->getinsurance();

	print "First option available is: " . $object->getshipname(1) . "\n";

	print "First option would cost: " . $object->getshiprate(1) . " to ship.\n";

	print "Item would be shipped out on " . $object->getshipdate(1) . "\n";

	print "Assuming a delivery date of " . $object->getshipdate(1) .
		", this item would arrive on: " . $object->getdelvdate(1) . "\n";

	print "Your item would likely be delivered on the " .
		$object->getdayofweek(1) . " day of the week.\n";

	printf("This item is %savailable for next day delivery\n",
			$object->getnextdayam(1) == 1 ? '' : 'NOT ');

	print "This shipping method would take approximately: " . $object->getestshipdays() .
		" days to arrive.\n";

	my $confirmation_included = $object->getconfirmation();

	my $extra_info = $object->getcomments();

#!/usr/bin/perl -w

package Business::CanadaPost;

use strict;
use LWP;
use vars qw($VERSION @ISA @EXPORT);
use Exporter;

@ISA		= qw(Exporter);
@EXPORT		= qw();
$VERSION	= '1.04';

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'} ? '<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 $ipaddress = $self->{'testing'} == 1 ? '206.191.4.228' : '216.191.36.73';
	my $result = $lwp->post("http://$ipaddress: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>(.+)<\/eparcel>/s;
	my ($resultcode) = $parcel =~ /<statusCode>([^<]+)<\/statusCode>/s;
	unless ($resultcode == 1)
	{
		my ($resultmessage) = $parcel =~ /<statusMessage>([^<]+)<\/statusMessage>/s;
		return $self->_error($resultmessage);
	}
	my ($products) = $parcel =~ /<product(.+)<\/product>/s; #should be greedy and get them all..
	my @options;
	foreach my $product (split /<\/product>\s+<product/s, $products)
	{
		my ($name)	= $product =~ /<name>([^<]+)<\/name>/s;
		my ($rate)	= $product =~ /<rate>([^<]+)<\/rate>/s;
		my ($shipdate)	= $product =~ /<shippingDate>([^<]+)<\/shippingDate>/s;
		my ($delvdate)	= $product =~ /<deliveryDate>([^<]+)<\/deliveryDate>/s;
		my ($dayofweek)	= $product =~ /<deliveryDayOfWeek>([^<]+)<\/deliveryDayOfWeek>/s;
		my ($nextdayam)	= $product =~ /<nextDayAM>([^<]+)<\/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>(.+)<\/shippingOptions>/s;
	if ($soptions =~ /<insurance>([^<]+)<\/insurance>/)
	{
		$self->{'shipinsurance'} = $1 eq 'No' ? 0 : 1;
	}
	if ($soptions =~ /<deliveryConfirmation>([^<]+)<\/deliveryConfirmation>/)
	{
		$self->{'shipconfirm'} = $1 eq 'No' ? 0 : 1;
	}
	if ($soptions =~ /<signature>([^<]+)<\/signature>/)
	{
		$self->{'signature'} = $1 eq 'No' ? 0 : 1;
	}

	$self->{'shipcomments'} = $1 if $parcel =~ /<comment>([^<]+)<\/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('<?xml version="1.0" ?>
<eparcel>
		<language>%s</language>
		<ratesAndServicesRequest>
				<merchantCPCID>%s</merchantCPCID>
				%s
				%s
				<itemsPrice>%.2f</itemsPrice>%s',
		$self->{'language'} || 'en',
		$self->{'merchantid'} || return $self->_error(7),
		$self->{'frompostalcode'} ? "<fromPostalCode>" . $self->{'frompostalcode'} . "</fromPostalCode>\n" : '',
		$self->{'turnaroundtime'} ? "<turnAroundTime>" . $self->{'turnaroundtime'} . "</turnAroundTime>\n" : '',
		$self->{'totalprice'} || '0.00',
	   	"\n");

	
	$xmlfile .= "		<lineItems>\n";
	for (my $n = 0; $n < @items; $n += 7)
	{
		$xmlfile .= sprintf("			<item>
								<quantity>%d</quantity>
								<weight>%01.2f</weight>
								<length>%01.2f</length>
								<width>%01.2f</width>
								<height>%01.2f</height>
								<description>%s</description>
								%s
						</item>\n",
			@items[$n .. $n+6]);
	}
	$xmlfile .= "		</lineItems>\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("		<city>%s</city>
				<provOrState>%s</provOrState>
				<country>%s</country>
				<postalCode>%s</postalCode>
		</ratesAndServicesRequest>
</eparcel>",
	$self->{'city'} || ' ',
	$self->{'provstate'} || ' ',
	$self->{'country'},
	$self->{'postalcode'} || ' ');

	return $xmlfile;
} # }}}

1;

__END__

# vim:foldmethod=marker:ts=8