434 lines
14 KiB
Perl
434 lines
14 KiB
Perl
package WebGUI::Shop::ShipDriver::USPS;
|
|
|
|
use strict;
|
|
use Moose;
|
|
use WebGUI::Definition::Shop;
|
|
extends qw/WebGUI::Shop::ShipDriver/;
|
|
define pluginName => ['United States Postal Service', 'ShipDriver_USPS'];
|
|
property instructions => (
|
|
fieldType => 'readOnly',
|
|
label => ['instructions', 'ShipDriver_USPS'],
|
|
builder => '_instructions_default',
|
|
lazy => 1,
|
|
noFormProcess => 1,
|
|
);
|
|
sub _instructions_default {
|
|
my $session = shift->session;
|
|
my $i18n = WebGUI::International->new($session, 'ShipDriver_USPS');
|
|
return $i18n->get('instructions');
|
|
}
|
|
property userId => (
|
|
fieldType => 'text',
|
|
label => ['userid', 'ShipDriver_USPS'],
|
|
hoverHelp => ['userid help', 'ShipDriver_USPS'],
|
|
default => '',
|
|
);
|
|
property password => (
|
|
fieldType => 'password',
|
|
label => ['password', 'ShipDriver_USPS'],
|
|
hoverHelp => ['password help', 'ShipDriver_USPS'],
|
|
default => '',
|
|
);
|
|
property sourceZip => (
|
|
fieldType => 'zipcode',
|
|
label => ['source zipcode', 'ShipDriver_USPS'],
|
|
hoverHelp => ['source zipcode help', 'ShipDriver_USPS'],
|
|
default => '',
|
|
);
|
|
property shipType => (
|
|
fieldType => 'selectBox',
|
|
label => ['ship type', 'ShipDriver_USPS'],
|
|
hoverHelp => ['ship type help', 'ShipDriver_USPS'],
|
|
default => 'PARCEL',
|
|
options => \&_shipType_options,
|
|
);
|
|
sub _shipType_options {
|
|
my $session = shift->session;
|
|
my $i18n = WebGUI::International->new($session, 'ShipDriver_USPS');
|
|
tie my %shippingTypes, 'Tie::IxHash';
|
|
##Note, these keys are used by buildXML
|
|
$shippingTypes{'PRIORITY VARIABLE'} = $i18n->get('priority variable');
|
|
$shippingTypes{'PRIORITY'} = $i18n->get('priority');
|
|
$shippingTypes{'EXPRESS' } = $i18n->get('express');
|
|
$shippingTypes{'PARCEL' } = $i18n->get('parcel post');
|
|
return \%shippingTypes;
|
|
}
|
|
property addInsurance => (
|
|
fieldType => 'yesNo',
|
|
label => ['add insurance', 'ShipDriver_USPS'],
|
|
hoverHelp => ['add insurance help', 'ShipDriver_USPS'],
|
|
default => 0,
|
|
);
|
|
property insuranceRates => (
|
|
fieldType => 'textarea',
|
|
label => ['insurance rates', 'ShipDriver_USPS'],
|
|
hoverHelp => ['insurance rates help', 'ShipDriver_USPS'],
|
|
default => "50:1.75\n100:2.25",
|
|
);
|
|
|
|
|
|
|
|
use WebGUI::Exception;
|
|
use XML::Simple;
|
|
use LWP;
|
|
use Tie::IxHash;
|
|
use Data::Dumper;
|
|
|
|
=head1 NAME
|
|
|
|
Package WebGUI::Shop::ShipDriver::USPS
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Shipping driver for the United States Postal Service, domestic shipping services.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
=head1 METHODS
|
|
|
|
See the master class, WebGUI::Shop::ShipDriver for information about
|
|
base methods. These methods are customized in this class:
|
|
|
|
=cut
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 buildXML ( $cart, @packages )
|
|
|
|
Returns XML for submitting to the US Postal Service servers
|
|
|
|
=head3 $cart
|
|
|
|
A WebGUI::Shop::Cart object. This allows us access to the user's
|
|
address book
|
|
|
|
=head3 @packages
|
|
|
|
An array of array references. Each array element is 1 set of items. The
|
|
quantity of items will vary in each set. If the quantity of an item
|
|
is more than 1, then we will check for shipping 1 item, and multiple the
|
|
result by the quantity, rather than doing several identical checks.
|
|
|
|
=cut
|
|
|
|
sub buildXML {
|
|
my ($self, $cart, @packages) = @_;
|
|
tie my %xmlHash, 'Tie::IxHash';
|
|
%xmlHash = ( RateV3Request => {}, );
|
|
my $xmlTop = $xmlHash{RateV3Request};
|
|
$xmlTop->{USERID} = $self->userId;
|
|
$xmlTop->{Package} = [];
|
|
##Do a request for each package.
|
|
my $packageIndex;
|
|
my $shipType = $self->shipType;
|
|
my $service = $shipType eq 'PRIORITY VARIABLE'
|
|
? 'PRIORITY'
|
|
: $shipType;
|
|
my $sourceZip = $self->sourceZip;
|
|
$sourceZip =~ s/^(\d{5}).*$/$1/;
|
|
PACKAGE: for(my $packageIndex = 0; $packageIndex < scalar @packages; $packageIndex++) {
|
|
my $package = $packages[$packageIndex];
|
|
next PACKAGE unless scalar @{ $package };
|
|
tie my %packageData, 'Tie::IxHash';
|
|
my $weight = 0;
|
|
foreach my $item (@{ $package }) {
|
|
my $sku = $item->getSku;
|
|
my $itemWeight = $sku->getWeight();
|
|
##Items that ship separately with a quantity > 1 are rate estimated as 1 item and then the
|
|
##shipping cost is multiplied by the quantity.
|
|
if (! $sku->isShippingSeparately ) {
|
|
$itemWeight *= $item->get('quantity');
|
|
}
|
|
$weight += $itemWeight;
|
|
}
|
|
my $pounds = int($weight);
|
|
my $ounces = sprintf '%3.1f', (16 * ($weight - $pounds));
|
|
if ($pounds == 0 && $ounces eq '0.0' ) {
|
|
$ounces = 0.1;
|
|
}
|
|
my $destination = $package->[0]->getShippingAddress;
|
|
my $destZipCode = $destination->get('code');
|
|
$destZipCode =~ s/^(\d{5}).*$/$1/;
|
|
$packageData{ID} = $packageIndex;
|
|
$packageData{Service} = [ $service ];
|
|
$packageData{ZipOrigination} = [ $self->sourceZip ];
|
|
$packageData{ZipDestination} = [ $destZipCode ];
|
|
$packageData{Pounds} = [ $pounds ];
|
|
$packageData{Ounces} = [ $ounces ];
|
|
if ($shipType eq 'PRIORITY') {
|
|
$packageData{Container} = [ 'FLAT RATE BOX' ];
|
|
}
|
|
elsif ($shipType eq 'PRIORITY VARIABLE') {
|
|
#$packageData{Container} = [ 'VARIABLE' ];
|
|
}
|
|
$packageData{Size} = [ 'REGULAR' ];
|
|
$packageData{Machinable} = [ 'true' ];
|
|
push @{ $xmlTop->{Package} }, \%packageData;
|
|
}
|
|
my $xml = XMLout(\%xmlHash,
|
|
KeepRoot => 1,
|
|
NoSort => 1,
|
|
NoIndent => 1,
|
|
KeyAttr => {
|
|
Package => 'ID',
|
|
},
|
|
SuppressEmpty => 0,
|
|
);
|
|
return $xml;
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 calculate ( $cart )
|
|
|
|
Returns a shipping price.
|
|
|
|
=head3 $cart
|
|
|
|
A WebGUI::Shop::Cart object. The contents of the cart are analyzed to calculate
|
|
the shipping costs. If no items in the cart require shipping, then no shipping
|
|
costs are assessed.
|
|
|
|
=cut
|
|
|
|
sub calculate {
|
|
my ($self, $cart) = @_;
|
|
if (! $self->sourceZip) {
|
|
WebGUI::Error::InvalidParam->throw(error => q{Driver configured without a source zipcode.});
|
|
}
|
|
if (! $self->userId) {
|
|
WebGUI::Error::InvalidParam->throw(error => q{Driver configured without a USPS userId.});
|
|
}
|
|
if ($cart->getShippingAddress->get('country') ne 'United States') {
|
|
WebGUI::Error::InvalidParam->throw(error => q{Driver only handles domestic shipping});
|
|
}
|
|
my $cost = 0;
|
|
##Sort the items into shippable bundles.
|
|
my @shippableUnits = $self->_getShippableUnits($cart);
|
|
my $packageCount = scalar @shippableUnits;
|
|
if ($packageCount > 25) {
|
|
WebGUI::Error::InvalidParam->throw(error => q{Cannot do USPS lookups for more than 25 items.});
|
|
}
|
|
my $anyShippable = $packageCount > 0 ? 1 : 0;
|
|
return $cost unless $anyShippable;
|
|
##Build XML ($cart, @shippableUnits)
|
|
my $xml = $self->buildXML($cart, @shippableUnits);
|
|
##Do request ($xml)
|
|
my $response = $self->_doXmlRequest($xml);
|
|
##Error handling
|
|
if (! $response->is_success) {
|
|
WebGUI::Error::Shop::RemoteShippingRate->throw(error => 'Problem connecting to USPS Web Tools: '. $response->status_line);
|
|
}
|
|
my $returnedXML = $response->content;
|
|
my $xmlData = XMLin($returnedXML, KeepRoot => 1, ForceArray => [qw/Package/]);
|
|
if (exists $xmlData->{Error}) {
|
|
WebGUI::Error::Shop::RemoteShippingRate->throw(error => 'Problem with USPS Web Tools XML: '. $xmlData->{Error}->{Description});
|
|
}
|
|
##Summarize costs from returned data
|
|
$cost = $self->_calculateFromXML($xmlData, @shippableUnits);
|
|
$cost += $self->_calculateInsurance(@shippableUnits);
|
|
return $cost;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 _calculateFromXML ( $xmlData, @shippableUnits )
|
|
|
|
Takes data from the USPS and returns the calculated shipping price.
|
|
|
|
=head3 $xmlData
|
|
|
|
Processed XML data from an XML rate request, processed in perl data structure. The data is expected to
|
|
have this structure:
|
|
|
|
{
|
|
RateV3Response => {
|
|
Package => [
|
|
{
|
|
ID => 0,
|
|
Postage => {
|
|
Rate => some_number
|
|
}
|
|
},
|
|
]
|
|
}
|
|
}
|
|
|
|
=head3 @shippableUnits
|
|
|
|
The set of shippable units, which are required to do quantity lookups.
|
|
|
|
=cut
|
|
|
|
sub _calculateFromXML {
|
|
my ($self, $xmlData, @shippableUnits) = @_;
|
|
my $cost = 0;
|
|
foreach my $package (@{ $xmlData->{RateV3Response}->{Package} }) {
|
|
my $id = $package->{ID};
|
|
my $rate = $package->{Postage}->{Rate};
|
|
##Error check for invalid index
|
|
if ($id < 0 || $id > $#shippableUnits || $id !~ /^\d+$/) {
|
|
WebGUI::Error::Shop::RemoteShippingRate->throw(error => "Illegal package index returned by USPS: $id");
|
|
}
|
|
if (exists $package->{Error}) {
|
|
WebGUI::Error::Shop::RemoteShippingRate->throw(error => $package->{Error}->{Description});
|
|
}
|
|
my $unit = $shippableUnits[$id];
|
|
if ($unit->[0]->getSku->isShippingSeparately) {
|
|
##This is a single item due to ships separately. Since in reality there will be
|
|
## N things being shipped, multiply the rate by the quantity.
|
|
$cost += $rate * $unit->[0]->get('quantity');
|
|
}
|
|
else {
|
|
##This is a loose bundle of items, all shipped together
|
|
$cost += $rate;
|
|
}
|
|
}
|
|
return $cost;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 _calculateInsurance ( @shippableUnits )
|
|
|
|
Takes data from the USPS and returns the calculated shipping price.
|
|
|
|
=head3 @shippableUnits
|
|
|
|
The set of shippable units, which are required to do quantity and cost lookups.
|
|
|
|
=cut
|
|
|
|
sub _calculateInsurance {
|
|
my ($self, @shippableUnits) = @_;
|
|
my $insuranceCost = 0;
|
|
return $insuranceCost unless $self->addInsurance && $self->insuranceRates;
|
|
my @insuranceTable = _parseInsuranceRates($self->insuranceRates);
|
|
##Sort by decreasing value for easy post processing
|
|
@insuranceTable = sort { $a->[0] <=> $b->[0] } @insuranceTable;
|
|
foreach my $package (@shippableUnits) {
|
|
my $value = 0;
|
|
ITEM: foreach my $item (@{ $package }) {
|
|
$value += $item->getSku->getPrice() * $item->get('quantity');
|
|
}
|
|
my $pricePoint;
|
|
POINT: foreach my $point (@insuranceTable) {
|
|
if ($value < $point->[0]) {
|
|
$pricePoint = $point;
|
|
last POINT;
|
|
}
|
|
}
|
|
if (!defined $pricePoint) {
|
|
$pricePoint = $insuranceTable[-1];
|
|
}
|
|
$insuranceCost += $pricePoint->[1];
|
|
}
|
|
return $insuranceCost;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 _parseInsuranceRates ( $rates )
|
|
|
|
Take the user entered data, a string, and turn it into an array.
|
|
|
|
=head3 $rates
|
|
|
|
The rate data entered by the user. One set of data per line. Each line has the value of
|
|
shipment, a colon, and the cost of insuring a shipment of that value.
|
|
|
|
=cut
|
|
|
|
sub _parseInsuranceRates {
|
|
my $rates = shift;
|
|
$rates =~ tr/\r//d;
|
|
my $number = qr/\d+(?:\.\d+)?/;
|
|
my $rate = qr{ \s* $number \s* : \s* $number \s* }x;
|
|
return () if ($rates !~ m{ \A (?: $rate \r?\n )* $rate (?:\r\n)? \Z }x);
|
|
my @lines = split /\n/, $rates;
|
|
my @table = ();
|
|
foreach my $line (@lines) {
|
|
$line =~ s/\s+//g;
|
|
my ($value, $cost) = split /:/, $line;
|
|
push @table, [ $value, $cost ];
|
|
}
|
|
return @table;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 _doXmlRequest ( $xml )
|
|
|
|
Contact the USPS website and submit the XML for a shipping rate lookup.
|
|
Returns a LWP::UserAgent response object.
|
|
|
|
=head3 $xml
|
|
|
|
XML to send. It has some very high standards, including XML components in
|
|
the right order and sets of allowed tags.
|
|
|
|
=cut
|
|
|
|
sub _doXmlRequest {
|
|
my ($self, $xml) = @_;
|
|
my $userAgent = LWP::UserAgent->new;
|
|
$userAgent->env_proxy;
|
|
$userAgent->agent('WebGUI');
|
|
$userAgent->timeout('45');
|
|
my $url = 'http://production.shippingapis.com/ShippingAPI.dll?API=RateV3&XML=';
|
|
$url .= $xml;
|
|
my $request = HTTP::Request->new(GET => $url);
|
|
my $response = $userAgent->request($request);
|
|
return $response;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 _getShippableUnits ( $cart )
|
|
|
|
This is a private method.
|
|
|
|
Sorts items into the cart by how they must be shipped, together, separate,
|
|
etc. Returns an array of array references of cart items grouped by
|
|
whether or not they ship separately, and then sorted by destination
|
|
zip code.
|
|
|
|
If an item in the cart must be shipped separately, but has a quantity greater
|
|
than 1, then for the purposes of looking up shipping costs it is returned
|
|
as 1 bundle, since the total cost can now be calculated by multiplying the
|
|
quantity together with the cost for a single unit.
|
|
|
|
For an empty cart (which shouldn't ever happen), it would return an empty array.
|
|
|
|
=head3 $cart
|
|
|
|
A WebGUI::Shop::Cart object. It provides access to the items in the cart
|
|
that must be sorted.
|
|
|
|
=cut
|
|
|
|
sub _getShippableUnits {
|
|
my ($self, $cart) = @_;
|
|
my @shippableUnits = ();
|
|
##Loose units are sorted by zip code.
|
|
my %looseUnits = ();
|
|
ITEM: foreach my $item (@{$cart->getItems}) {
|
|
my $sku = $item->getSku;
|
|
next ITEM unless $sku->isShippingRequired;
|
|
if ($sku->isShippingSeparately) {
|
|
push @shippableUnits, [ $item ];
|
|
}
|
|
else {
|
|
my $zip = $item->getShippingAddress->get('code');
|
|
if ($item->getShippingAddress->get('country') ne 'United States') {
|
|
WebGUI::Error::InvalidParam->throw(error => q{Driver only handles domestic shipping});
|
|
}
|
|
push @{ $looseUnits{$zip} }, $item;
|
|
}
|
|
}
|
|
push @shippableUnits, values %looseUnits;
|
|
return @shippableUnits;
|
|
}
|
|
|
|
1;
|