oqapi/webgui
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'master' into WebGUI8

Browse source
This commit is contained in:
Graham Knop 2010-04-13 07:50:02 -05:00
commit 2400f19099
797 changed files with 33894 additions and 27196 deletions
Download patch file Download diff file Expand all files Collapse all files

26
lib/WebGUI/Shop/Admin.pm
View file

@ -180,6 +180,13 @@ sub www_editSettings {
label => $i18n->get("edit address template"),
hoverHelp => $i18n->get("edit address template help"),
);
$form->template(
name => "selectGatewayTemplateId",
value => $setting->get("selectGatewayTemplateId"),
label => $i18n->get("select gateway template"),
namespace => "Shop/selectGateway",
hoverHelp => $i18n->get("select gateway template help"),
);
$form->template(
name => "shopMyPurchasesTemplateId",
value => $setting->get("shopMyPurchasesTemplateId"),
@ -194,6 +201,21 @@ sub www_editSettings {
label => $i18n->get("my purchases detail template"),
hoverHelp => $i18n->get("my purchases detail template help"),
);
$form->template(
name => 'shopReceiptEmailTemplateId',
namespace => "Shop/EmailReceipt",
label => $i18n->get("receipt email template"),
hoverHelp => $i18n->get("receipt email template help"),
defaultValue => 'bPz1yk6Y9uwMDMBcmMsSCg',
value => $setting->get("shopReceiptEmailTemplateId"),
);
$form->group(
name => 'shopSaleNotificationGroupId',
label => $i18n->get("sale notification group"),
hoverHelp => $i18n->get("sale notification group help"),
defaultValue => '3',
value => $setting->get("shopSaleNotificationGroupId"),
);
$form->submit;
return $ac->render($form->print, $i18n->get("shop settings"));
}
@ -213,12 +235,12 @@ sub www_editSettingsSave {
# Save shop templates
foreach my $template (qw(shopMyPurchasesDetailTemplateId shopMyPurchasesTemplateId
shopCartTemplateId shopAddressBookTemplateId shopAddressTemplateId)) {
shopCartTemplateId shopAddressBookTemplateId shopAddressTemplateId selectGatewayTemplateId shopReceiptEmailTemplateId)) {
$setting->set($template, $form->get($template, "template"));
}
# Save group settings
foreach my $group (qw(groupIdCashier groupIdAdminCommerce)) {
foreach my $group (qw(groupIdCashier groupIdAdminCommerce shopSaleNotificationGroupId)) {
$setting->set($group, $form->get($group, "group"));
}

43
lib/WebGUI/Shop/Cart.pm
View file

@ -14,6 +14,7 @@ use WebGUI::Shop::Credit;
use WebGUI::Shop::Ship;
use WebGUI::Shop::Tax;
use WebGUI::User;
use Tie::IxHash;
=head1 NAME
@ -520,6 +521,9 @@ sub readyForCheckout {
return 0 if $total < $requiredAmount;
}
##Must have a configured shipping id.
return 0 if ! $self->get('shipperId');
##Check for any other logged errors
return 0 if $error{ id $self };
@ -843,22 +847,37 @@ sub www_view {
$var{shippingAddress} = $address->getHtmlFormatted;
my $ship = WebGUI::Shop::Ship->new($self->session);
my $options = $ship->getOptions($self);
my %formOptions = ();
my $defaultOption = "";
foreach my $option (keys %{$options}) {
$defaultOption = $option;
$formOptions{$option} = $options->{$option}{label}." (".$self->formatCurrency($options->{$option}{price}).")";
}
if ($defaultOption) {
$var{shippingOptions} = WebGUI::Form::selectBox($session, {name=>"shipperId", options=>\%formOptions, defaultValue=>$defaultOption, value=>$self->get("shipperId")});
$var{shippingPrice} = ($self->get("shipperId") ne "") ? $options->{$self->get("shipperId")}{price} : $options->{$defaultOption}{price};
$var{shippingPrice} = $self->formatCurrency($var{shippingPrice});
}
else {
my $numberOfOptions = scalar keys %{ $options };
if ($numberOfOptions < 1) {
$var{shippingOptions} = '';
$var{shippingPrice} = 0;
$error{id $self} = $i18n->get("No shipping plugins configured");
}
elsif ($numberOfOptions == 1) {
my ($option) = keys %{ $options };
$self->update({ shipperId => $option });
$var{shippingPrice} = $options->{$self->get("shipperId")}->{price};
$var{shippingPrice} = $self->formatCurrency($var{shippingPrice});
}
else {
tie my %formOptions, 'Tie::IxHash';
$formOptions{''} = $i18n->get('Choose a shipping method');
foreach my $option (keys %{$options}) {
$formOptions{$option} = $options->{$option}{label}." (".$self->formatCurrency($options->{$option}{price}).")";
}
$var{shippingOptions} = WebGUI::Form::selectBox($session, {name=>"shipperId", options=>\%formOptions, value=>$self->get("shipperId")});
if (!exists $options->{$self->get('shipperId')}) {
$self->update({shipperId => ''});
}
if (my $shipperId = $self->get('shipperId')) {
$var{shippingPrice} = $options->{$shipperId}->{price};
}
else {
$var{shippingPrice} = 0;
$error{id $self} = ($i18n->get('Choose a shipping method and update the cart to checkout'));
}
$var{shippingPrice} = $self->formatCurrency($var{shippingPrice});
}
}
# Tax variables

14
lib/WebGUI/Shop/Pay.pm
View file

@ -410,10 +410,11 @@ sub www_selectPaymentGateway {
# Complete Transaction if it's a $0 transaction.
my $total = $cart->calculateTotal;
if (($total + $cart->calculateShopCreditDeduction($total)) == 0) {
if (sprintf('%.2f', $total + $cart->calculateShopCreditDeduction($total)) eq '0.00') {
my $transaction = WebGUI::Shop::Transaction->create($session, {cart => $cart});
$transaction->completePurchase('zero', 'success', 'success');
$cart->onCompletePurchase;
$transaction->sendNotifications();
return $transaction->thankYou();
}
@ -423,12 +424,15 @@ sub www_selectPaymentGateway {
# TODO: If only one payOption exists, just send us there
# In order to do this, the PayDriver must give us a direct URL to go to
my $output .= $i18n->get('choose payment gateway message');
my $var;
my @paymentGateways;
foreach my $payOption ( values %{$payOptions} ) {
$output .= $payOption->{button} . '<br />';
push @paymentGateways, $payOption;
}
return $session->style->userStyle( $output );
$var->{ paymentGateways } = \@paymentGateways;
$var->{ choose } = $i18n->get('choose payment gateway message');
my $template = WebGUI::Asset::Template->new($session, $session->setting->get("selectGatewayTemplateId"));
return $session->style->userStyle($template->process($var));
}
1;

58
lib/WebGUI/Shop/PayDriver.pm
View file

@ -237,19 +237,6 @@ sub definition {
hoverHelp => $i18n->get('who can use help'),
defaultValue => 7,
},
receiptEmailTemplateId => {
fieldType => 'template',
namespace => "Shop/EmailReceipt",
label => $i18n->get("receipt email template"),
hoverHelp => $i18n->get("receipt email template help"),
defaultValue => 'bPz1yk6Y9uwMDMBcmMsSCg',
},
saleNotificationGroupId => {
fieldType => 'group',
label => $i18n->get("sale notification group"),
hoverHelp => $i18n->get("sale notification group help"),
defaultValue => '3',
},
);
my %properties = (
@ -662,7 +649,7 @@ sub processTransaction {
if ($success) {
$transaction->completePurchase($transactionCode, $statusCode, $statusMessage);
$cart->onCompletePurchase;
$self->sendNotifications($transaction);
$transaction->sendNotifications();
}
else {
$transaction->denyPurchase($transactionCode, $statusCode, $statusMessage);
@ -680,49 +667,6 @@ Accessor for the session object. Returns the session object.
=cut
#-------------------------------------------------------------------
=head2 sendNotifications ( transaction )
Sends out a receipt and a sale notification to the buyer and the store owner respectively.
=cut
sub sendNotifications {
my ($self, $transaction) = @_;
my $session = $self->session;
my $i18n = WebGUI::International->new($session, 'PayDriver');
my $url = $session->url;
my $var = $transaction->getTransactionVars;
# render
my $template = WebGUI::Asset::Template->newById( $session, $self->get("receiptEmailTemplateId") );
my $inbox = WebGUI::Inbox->new($session);
my $receipt = $template->process( $var );
WebGUI::Macro::process($session, \$receipt);
# purchase receipt
$inbox->addMessage( {
message => $receipt,
subject => $i18n->get('receipt subject') . ' ' . $transaction->get('orderNumber'),
userId => $transaction->get('userId'),
status => 'completed',
} );
# shop owner notification
# Shop owner uses method=view rather than method=viewMy
$var->{viewDetailUrl} = $url->page( 'shop=transaction;method=view;transactionId='.$transaction->getId, 1 );
my $notification = $template->process( $var );
WebGUI::Macro::process($session, \$notification);
$inbox->addMessage( {
message => $notification,
subject => $i18n->get('a sale has been made') . ' ' . $transaction->get('orderNumber'),
groupId => $self->get('saleNotificationGroupId'),
status => 'unread',
} );
}
#-------------------------------------------------------------------
=head2 update ( $options )

1
lib/WebGUI/Shop/PayDriver/ITransact.pm
View file

@ -810,6 +810,7 @@ sub www_getCredentials {
$var->{checkoutButton} = WebGUI::Form::submit($session, {
value => $i18n->get('checkout button', 'Shop'),
extras => 'onclick="this.disabled=true;this.form.submit(); return false;"',
});
my $template = eval { WebGUI::Asset::Template->newById($session, $self->get("credentialsTemplateId")); };

1
lib/WebGUI/Shop/PayDriver/PayPal.pm
View file

@ -17,7 +17,6 @@ package WebGUI::Shop::PayDriver::PayPal;
## this holds some shared functionality, and MUST be overridden for a full payment driver
use strict;
use base qw/WebGUI::Shop::PayDriver/;
use warnings;
=head1 NAME

1
lib/WebGUI/Shop/PayDriver/PayPal/PayPalStd.pm
View file

@ -15,7 +15,6 @@ package WebGUI::Shop::PayDriver::PayPal::PayPalStd;
=cut
use strict;
use warnings;
use base qw/WebGUI::Shop::PayDriver::PayPal/;

124
lib/WebGUI/Shop/PayDriver/_PayDriver.skeleton Normal file
View file

@ -0,0 +1,124 @@
package WebGUI::Shop::PayDriver::Skeleton; #change the Skeleton with your own PayDriver name
=head1 LEGAL
-------------------------------------------------------------------
WebGUI is Copyright 2001-2009 Plain Black Corporation.
-------------------------------------------------------------------
Please read the legal notices (docs/legal.txt) and the license
(docs/license.txt) that came with this distribution before using
this software.
-------------------------------------------------------------------
http://www.plainblack.com info@plainblack.com
-------------------------------------------------------------------
=cut
use strict;
use WebGUI::Shop::PayDriver;
use base qw/WebGUI::Shop::PayDriver/;
#-------------------------------------------------------------------
=head2 definition ( )
In the definition you can add your own properties
=cut
sub definition {
my $class = shift;
my $session = shift;
my $definition = shift;
WebGUI::Error::InvalidParam->throw( error => q{Must provide a session variable} )
unless $session && ref $session eq 'WebGUI::Session';
tie my %fields, 'Tie::IxHash';
#add some fields if you need your own parameters
# %fields = (
# currency => {
# fieldType => 'text',
# label => 'currency',
# hoverHelp => 'Fill in your currency',
# defaultValue => 'EUR',
# maxlength => 3,
# size => 3,
# },
# );
push @{ $definition }, {
name => 'Skeleton', #change the Skeleton with your own PayDriver name
properties => \%fields,
};
return $class->SUPER::definition($session, $definition);
}
#-------------------------------------------------------------------
=head2 canCheckoutCart ( )
Returns whether the cart can be checked out by this plugin.
=cut
sub canCheckoutCart {
my $self = shift;
my $cart = $self->getCart;
return 0 unless $cart->readyForCheckout;
return 0 if $cart->requiresRecurringPayment;
return 1;
}
#-------------------------------------------------------------------
=head2 getButton ( )
Create a button for the screen where you select the payment method. Redirect it
to your first www_ method you need
=cut
sub getButton {
my $self = shift;
my $button = WebGUI::Form::formHeader($self->session) .
$self->getDoFormTags('finish') .
WebGUI::Form::submit($self->session, {value => $self->get('label') }) .
WebGUI::Form::formFooter($self->session);
return $button;
}
#-------------------------------------------------------------------
=head2 processPayment ( )
Should interact with the payment gateway and then return an array containing
success/failure (as 1 or 0), transaction code (or payment gateway's transaction
id), status code, and status message.
=cut
sub processPayment {
return (1, undef, 1, 'Success');
}
#-------------------------------------------------------------------
=head2 www_dosomething ( )
Create your own www_ method. They are available from the outside.
So www_finish can be called directly with:
http://www.mysite.com/?shop=pay;method=do;do=finish
=cut
sub www_finish {
my ($self) = @_;
#prcess the transaction (it needs an WebGUI::Shop::Address object)
my $transaction = $self->processTransaction(
$self->getCart->getShippingAddress
);
#return the thankyou page to the user
return $transaction->thankYou();
}
1;

533
lib/WebGUI/Shop/ShipDriver/UPS.pm Normal file
View file

@ -0,0 +1,533 @@
package WebGUI::Shop::ShipDriver::UPS;
use strict;
use base qw/WebGUI::Shop::ShipDriver/;
use WebGUI::Exception;
use WebGUI::Exception::Shop;
use XML::Simple;
use LWP;
use Tie::IxHash;
use Locales;
use Class::InsideOut qw/ :std /;
use Data::Dumper;
public testMode => my %testMode;
=head1 NAME
Package WebGUI::Shop::ShipDriver::UPS
=head1 DESCRIPTION
Shipping driver for the United Parcel Service, for US Domestic shipping only.
The UPS XML interface will only do a lookup for one destination at a time. However,
each destination may have multiple packages. This means that if a cart holds packages
with multiple destinations, that multiple requests must be sent to the UPS server.
=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 UPS servers
=head3 $cart
A WebGUI::Shop::Cart object. This allows us access to the user's
address book
=head3 $packages
An array reference. Each array element is 1 set of items. The
quantity of items will vary in each set. All packages in the set must
go to the same zipcode.
=cut
sub buildXML {
my ($self, $cart, $packages) = @_;
#tie my %xmlHash, 'Tie::IxHash';
my %xmlHash = (
AccessRequest => {},
);
my $xmlAcc = $xmlHash{AccessRequest};
$xmlAcc->{'xml:lang'} = 'en-US';
$xmlAcc->{AccessLicenseNumber} = [ $self->get('licenseNo') ];
$xmlAcc->{UserId} = [ $self->get('userId') ];
$xmlAcc->{Password} = [ $self->get('password') ];
my $localizedCountry = Locales->new('en');
my $xml = XMLout(\%xmlHash,
KeepRoot => 1,
NoSort => 1,
SuppressEmpty => 0,
XMLDecl => 1,
);
my $destination = $packages->[0]->[0]->getShippingAddress;
%xmlHash = (
RatingServiceSelectionRequest => {},
);
my $xmlRate = $xmlHash{RatingServiceSelectionRequest };
$xmlRate->{'xml:lang'} = 'en-US';
$xmlRate->{Request} = {
# Shown in example request, but optional
# TransactionReference => {
# CustomerContext => [ 'Rating and Service' ],
# XpciVersion => [ 1.0001 ],
# },
RequestAction => [ 'Rate' ],
# RequestOption => [ 'shop' ],
};
$xmlRate->{PickupType} = {
Code => [ $self->get('pickupType') ],
};
$xmlRate->{CustomerClassification} = {
Code => [ $self->get('customerClassification') ],
};
$xmlRate->{Shipment} = {
Shipper => {
Address => [ {
PostalCode => [ $self->get('sourceZip') ],
CountryCode => [ $localizedCountry->get_code_from_territory($self->get('sourceCountry')) ],
}, ],
},
ShipTo => {
Address => [ {
PostalCode => [ $destination->get('code') ],
CountryCode => [ $localizedCountry->get_code_from_territory($destination->get('country')) ],
} ],
},
Service => {
Code => [ $self->get('shipService') ],
},
Package => [],
};
if ($self->get('residentialIndicator') eq 'residential') {
$xmlRate->{Shipment}->{ShipTo}->{Address}->[0]->{ResidentialAddressIndicator} = [''];
}
my $packHash = $xmlRate->{Shipment}->{Package};
PACKAGE: foreach my $package (@{ $packages }) {
my $weight = 0;
ITEM: foreach my $item (@{ $package }) {
my $sku = $item->getSku();
next ITEM unless $sku->isShippingRequired;
##If shipsSeparately is set, the item was placed N times in the shippingBundles,
##where N is the quantity. This means that the quantity is wrong for
##any item where that option is set.
my $skuWeight = $sku->getWeight;
if (! $sku->shipsSeparately() ) {
$skuWeight *= $item->get('quantity');
}
$weight += $skuWeight;
}
next PACKAGE unless $weight;
$weight = sprintf "%.1f", $weight;
$weight = '0.1' if $weight == 0;
my $options = {
PackagingType => [ {
Code => [ '02' ],
} ],
PackageWeight => [ {
Weight => [ $weight ], ##Required formatting from spec
} ],
};
push @{ $packHash }, $options;
}
return '' unless scalar @{ $packHash }; ##Nothing to calculate shipping for.
$xml .= XMLout(\%xmlHash,
KeepRoot => 1,
NoSort => 1,
SuppressEmpty => '',
XMLDecl => 1,
);
return $xml;
}
#-------------------------------------------------------------------
=head2 calculate ( $cart )
Returns a shipping price. Since the UPS will only allow a lookup from one source
to one destination at a time, this method may make several XML requests from the
UPS server.
=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->get('sourceZip')) {
WebGUI::Error::InvalidParam->throw(error => q{Driver configured without a source zipcode.});
}
if (! $self->get('sourceCountry')) {
WebGUI::Error::InvalidParam->throw(error => q{Driver configured without a source country.});
}
if (! $self->get('userId')) {
WebGUI::Error::InvalidParam->throw(error => q{Driver configured without a UPS userId.});
}
if (! $self->get('password')) {
WebGUI::Error::InvalidParam->throw(error => q{Driver configured without a UPS password.});
}
if (! $self->get('licenseNo')) {
WebGUI::Error::InvalidParam->throw(error => q{Driver configured without a UPS license number.});
}
my $cost = 0;
##Sort the items into shippable bundles.
my @shippableUnits = $self->_getShippableUnits($cart);
my $packageCount = scalar @shippableUnits;
my $anyShippable = $packageCount > 0 ? 1 : 0;
return $cost unless $anyShippable;
#$cost = scalar @shippableUnits * $self->get('flatFee');
##Build XML ($cart, @shippableUnits)
foreach my $unit (@shippableUnits) {
if ($packageCount > 200) {
WebGUI::Error::InvalidParam->throw(error => q{Cannot do UPS lookups for more than 200 items.});
}
my $xml = $self->buildXML($cart, $unit);
##Do request ($xml)
my $response = $self->_doXmlRequest($xml);
##Error handling
if (! $response->is_success) {
WebGUI::Error::Shop::RemoteShippingRate->throw(error => 'Problem connecting to UPS Web Tools: '. $response->status_line);
}
my $returnedXML = $response->content;
my $xmlData = XMLin($returnedXML, ForceArray => [qw/RatedPackage/]);
if (! $xmlData->{Response}->{ResponseStatusCode}) {
WebGUI::Error::Shop::RemoteShippingRate->throw(error => 'Problem with UPS Online Tools XML: '. $xmlData->{Response}->{Error}->{ErrorDescription});
}
##Summarize costs from returned data
$cost += $self->_calculateFromXML($xmlData);
}
return $cost;
}
#-------------------------------------------------------------------
=head2 _calculateFromXML ( $xmlData )
Takes data from the UPS and returns the calculated shipping price.
=head3 $xmlData
Processed data from an XML rate request, as a perl data structure. The data is expected to
have this structure:
{
RatedShipment => {
TotalCharges => {
MonetaryValue => xx.yy
}
}
}
=cut
sub _calculateFromXML {
my ($self, $xmlData) = @_;
##Additional error checking on the XML data can be done in here. Or, in the future,
##individual elements of the cost can be parsed and returned.
return $xmlData->{RatedShipment}->{TotalCharges}->{MonetaryValue};
}
#-------------------------------------------------------------------
=head2 definition ( $session )
This subroutine returns an arrayref of hashrefs, used to validate data put into
the object by the user, and to automatically generate the edit form to show
the user.
=cut
sub definition {
my $class = shift;
my $session = shift;
WebGUI::Error::InvalidParam->throw(error => q{Must provide a session variable})
unless ref $session eq 'WebGUI::Session';
my $definition = shift || [];
my $i18n = WebGUI::International->new($session, 'ShipDriver_UPS');
tie my %shippingTypes, 'Tie::IxHash';
##Other shipping types can be added below, but also need to be handled by the
##javascript.
$shippingTypes{'us domestic'} = $i18n->get('us domestic');
$shippingTypes{'us international'} = $i18n->get('us international');
tie my %shippingServices, 'Tie::IxHash';
##Note, these keys are required XML keywords in the UPS XML API.
##It needs a one of every key, regardless of the correct label.
##The right set of options is set via JavaScript in the form.
$shippingServices{'01'} = $i18n->get('us domestic 01');
$shippingServices{'02'} = $i18n->get('us domestic 02');
$shippingServices{'03'} = $i18n->get('us domestic 03');
$shippingServices{'07'} = $i18n->get('us international 07');
$shippingServices{'08'} = $i18n->get('us international 08');
$shippingServices{'11'} = $i18n->get('us international 11');
$shippingServices{'12'} = $i18n->get('us domestic 12');
$shippingServices{'13'} = $i18n->get('us domestic 13');
$shippingServices{'14'} = $i18n->get('us domestic 14');
$shippingServices{'54'} = $i18n->get('us international 54');
$shippingServices{'59'} = $i18n->get('us domestic 59');
$shippingServices{'65'} = $i18n->get('us international 65');
tie my %pickupTypes, 'Tie::IxHash';
##Note, these keys are required XML keywords in the UPS XML API.
$pickupTypes{'01'} = $i18n->get('pickup code 01');
$pickupTypes{'03'} = $i18n->get('pickup code 03');
$pickupTypes{'06'} = $i18n->get('pickup code 06');
$pickupTypes{'07'} = $i18n->get('pickup code 07');
$pickupTypes{'11'} = $i18n->get('pickup code 11');
$pickupTypes{'19'} = $i18n->get('pickup code 19');
$pickupTypes{'20'} = $i18n->get('pickup code 20');
tie my %customerClassification, 'Tie::IxHash';
##Note, these keys are required XML keywords in the UPS XML API.
$customerClassification{'01'} = $i18n->get('customer classification 01');
$customerClassification{'03'} = $i18n->get('customer classification 03');
$customerClassification{'04'} = $i18n->get('customer classification 04');
my $localizedCountries = Locales->new('en'); ##Note, for future i18n change the locale
tie my %localizedCountries, 'Tie::IxHash';
%localizedCountries = map { $_ => $_ } grep { !ref $_ } $localizedCountries->get_territory_names();
tie my %fields, 'Tie::IxHash';
%fields = (
instructions => {
fieldType => 'readOnly',
label => $i18n->get('instructions'),
defaultValue => $i18n->get('ups instructions'),
noFormProcess => 1,
},
userId => {
fieldType => 'text',
label => $i18n->get('userid'),
hoverHelp => $i18n->get('userid help'),
defaultValue => '',
},
password => {
fieldType => 'password',
label => $i18n->get('password'),
hoverHelp => $i18n->get('password help'),
defaultValue => '',
},
licenseNo => {
fieldType => 'text',
label => $i18n->get('license'),
hoverHelp => $i18n->get('license help'),
defaultValue => '',
},
sourceZip => {
fieldType => 'zipcode',
label => $i18n->get('source zipcode'),
hoverHelp => $i18n->get('source zipcode help'),
defaultValue => '',
},
sourceCountry => {
fieldType => 'selectBox',
label => $i18n->get('source country'),
hoverHelp => $i18n->get('source country help'),
options => \%localizedCountries,
defaultValue => 'US',
},
shipType => {
fieldType => 'selectBox',
label => $i18n->get('ship type'),
hoverHelp => $i18n->get('ship type help'),
options => \%shippingTypes,
defaultValue => 'us domestic',
extras => q{onchange="WebGUI.ShipDriver.UPS.changeServices(this.options[this.selectedIndex].value,'shipService_formId')"},
},
shipService => {
fieldType => 'selectBox',
label => $i18n->get('ship service'),
hoverHelp => $i18n->get('ship service help'),
options => \%shippingServices,
defaultValue => '03',
},
pickupType => {
fieldType => 'selectBox',
label => $i18n->get('pickup type'),
hoverHelp => $i18n->get('pickup type help'),
options => \%pickupTypes,
defaultValue => '01',
},
customerClassification => {
fieldType => 'selectBox',
label => $i18n->get('customer classification'),
hoverHelp => $i18n->get('customer classification help'),
options => \%customerClassification,
defaultValue => '01',
},
residentialIndicator => {
fieldType => 'radioList',
label => $i18n->get('residential'),
hoverHelp => $i18n->get('residential help'),
options => {
residential => $i18n->get('residential'),
commercial => $i18n->get('commercial'),
},
defaultValue => 'commercial',
},
##Note, if a flat fee is added to this driver, then according to the license
##terms the website must display a note to the user (shop customer) that additional
##fees have been added.
# flatFee => {
# fieldType => 'float',
# label => $i18n->get('flatFee'),
# hoverHelp => $i18n->get('flatFee help'),
# defaultValue => 0,
# },
);
my %properties = (
name => 'UPS',
properties => \%fields,
);
push @{ $definition }, \%properties;
return $class->SUPER::definition($session, $definition);
}
#-------------------------------------------------------------------
=head2 _doXmlRequest ( $xml )
Contact the UPS 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');
#
my $url;
if ($self->testMode) {
$url = 'https://wwwcie.ups.com/ups.app/xml/Rate';
}
else {
$url = 'https://wwwcie.ups.com/ups.app/xml/Rate';
}
my $request = HTTP::Request->new(POST => $url);
$request->content_type( 'text/xml' );
$request->content( $xml );
my $response = $userAgent->request($request);
return $response;
}
#-------------------------------------------------------------------
=head2 getEditForm ( )
Override the master method to stuff in some javascript.
=cut
sub getEditForm {
my $self = shift;
$self->session->style->setScript(
$self->session->url->extras('yui/build/utilities/utilities.js'),
{ type => 'text/javascript', },
);
$self->session->style->setScript(
$self->session->url->extras('yui/build/yahoo-dom-event/yahoo-dom-event.js'),
{ type => 'text/javascript', },
);
$self->session->style->setScript(
$self->session->url->extras('yui/build/json/json-min.js'),
{ type => 'text/javascript', },
);
$self->session->style->setScript(
$self->session->url->extras('yui-webgui/build/i18n/i18n.js'),
{ type => 'text/javascript', },
);
$self->session->style->setScript(
$self->session->url->extras('yui-webgui/build/ShipDriver/UPS.js'),
{ type => 'text/javascript', },
);
$self->session->style->setRawHeadTags(<<EOL);
<script type="text/javascript">
YAHOO.util.Event.onDOMReady( WebGUI.ShipDriver.UPS.initI18n );
</script>
EOL
return $self->SUPER::getEditForm();
}
#-------------------------------------------------------------------
=head2 _getShippableUnits ( $cart )
This is a private method.
Sorts items into the cart by how they must be shipped; together, separate,
etc, following these rules:
=over 4
=item *
Each item which ships separately is 1 shippable unit.
=item *
All loose items are bundled together by zip code.
=back
This method returns a
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) = @_;
##All units sorted by zip code. Loose units kept separately so they
##can be easily bundled together by zip code.
my %shippableUnits = ();
my %looseUnits = ();
ITEM: foreach my $item (@{$cart->getItems}) {
my $sku = $item->getSku;
next ITEM unless $sku->isShippingRequired;
my $zip = $item->getShippingAddress->get('code');
if ($sku->shipsSeparately) {
push @{ $shippableUnits{$zip} }, ( [ $item ] ) x $item->get('quantity');
}
else {
push @{ $looseUnits{$zip} }, $item;
}
}
##Merge the two together now
while (my ($zip, $units) = each %looseUnits) {
push @{ $shippableUnits{$zip} }, $units;
}
return values %shippableUnits;
}
1;

139
lib/WebGUI/Shop/ShipDriver/USPS.pm
View file

@ -6,6 +6,7 @@ use WebGUI::Exception;
use XML::Simple;
use LWP;
use Tie::IxHash;
use Data::Dumper;
=head1 NAME
@ -13,7 +14,7 @@ Package WebGUI::Shop::ShipDriver::USPS
=head1 DESCRIPTION
Shipping driver for the United States Postal Service.
Shipping driver for the United States Postal Service, domestic shipping services.
=head1 SYNOPSIS
@ -53,9 +54,12 @@ sub buildXML {
$xmlTop->{Package} = [];
##Do a request for each package.
my $packageIndex;
my $shipType = $self->get('shipType');
my $service = $shipType eq 'PRIORITY VARIABLE' ? 'PRIORITY'
: $shipType;
my $shipType = $self->get('shipType');
my $service = $shipType eq 'PRIORITY VARIABLE'
? 'PRIORITY'
: $shipType;
my $sourceZip = $self->get('sourceZip');
$sourceZip =~ s/^(\d{5}).*$/$1/;
PACKAGE: for(my $packageIndex = 0; $packageIndex < scalar @packages; $packageIndex++) {
my $package = $packages[$packageIndex];
next PACKAGE unless scalar @{ $package };
@ -72,9 +76,13 @@ sub buildXML {
$weight += $itemWeight;
}
my $pounds = int($weight);
my $ounces = int(16 * ($weight - $pounds));
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->get('sourceZip') ];
@ -126,6 +134,9 @@ sub calculate {
if (! $self->get('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);
@ -142,15 +153,16 @@ sub calculate {
my $response = $self->_doXmlRequest($xml);
##Error handling
if (! $response->is_success) {
WebGUI::Error::RemoteShippingRate->throw(error => 'Problem connecting to USPS Web Tools: '. $response->status_line);
WebGUI::Error::Shop::RemoteShippingRate->throw(error => 'Problem connecting to USPS Web Tools: '. $response->status_line);
}
my $returnedXML = $response->content;
my $xmlData = XMLin($returnedXML, ForceArray => [qw/Package/]);
my $xmlData = XMLin($returnedXML, KeepRoot => 1, ForceArray => [qw/Package/]);
if (exists $xmlData->{Error}) {
WebGUI::Error::RemoteShippingRate->throw(error => 'Problem with USPS Web Tools XML: '. $xmlData->{Description});
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;
}
@ -166,14 +178,16 @@ Processed XML data from an XML rate request, processed in perl data structure.
have this structure:
{
Package => [
{
ID => 0,
Postage => {
Rate => some_number
}
},
]
RateV3Response => {
Package => [
{
ID => 0,
Postage => {
Rate => some_number
}
},
]
}
}
=head3 @shippableUnits
@ -185,12 +199,15 @@ The set of shippable units, which are required to do quantity lookups.
sub _calculateFromXML {
my ($self, $xmlData, @shippableUnits) = @_;
my $cost = 0;
foreach my $package (@{ $xmlData->{Package} }) {
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) {
WebGUI::Error::RemoteShippingRate->throw(error => "Illegal package index returned by USPS: $id");
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) {
@ -208,6 +225,74 @@ sub _calculateFromXML {
#-------------------------------------------------------------------
=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->get('addInsurance') && $self->get('insuranceRates');
my @insuranceTable = _parseInsuranceRates($self->get('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 definition ( $session )
This subroutine returns an arrayref of hashrefs, used to validate data put into
@ -262,6 +347,18 @@ sub definition {
options => \%shippingTypes,
defaultValue => 'PARCEL',
},
addInsurance => {
fieldType => 'yesNo',
label => $i18n->get('add insurance'),
hoverHelp => $i18n->get('add insurance help'),
defaultValue => 0,
},
insuranceRates => {
fieldType => 'textarea',
label => $i18n->get('insurance rates'),
hoverHelp => $i18n->get('insurance rates help'),
defaultValue => "50:1.75\n100:2.25",
},
##Note, if a flat fee is added to this driver, then according to the license
##terms the website must display a note to the user (shop customer) that additional
##fees have been added.
@ -299,6 +396,7 @@ sub _doXmlRequest {
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);
@ -344,6 +442,9 @@ sub _getShippableUnits {
}
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;
}
}

411
lib/WebGUI/Shop/ShipDriver/USPSInternational.pm Normal file
View file

@ -0,0 +1,411 @@
package WebGUI::Shop::ShipDriver::USPSInternational;
use strict;
use base qw/WebGUI::Shop::ShipDriver/;
use WebGUI::Exception;
use XML::Simple;
use LWP;
use Tie::IxHash;
use Data::Dumper;
=head1 NAME
Package WebGUI::Shop::ShipDriver::USPSInternational
=head1 DESCRIPTION
Shipping driver for the United States Postal Service, international 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 = ( IntlRateRequest => {}, );
my $xmlTop = $xmlHash{IntlRateRequest};
$xmlTop->{USERID} = $self->get('userId');
$xmlTop->{Package} = [];
##Do a request for each package.
my $packageIndex;
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;
my $value = 0;
foreach my $item (@{ $package }) {
my $sku = $item->getSku;
my $itemWeight = $sku->getWeight();
my $itemValue = $sku->getPrice();
##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->shipsSeparately ) {
$itemWeight *= $item->get('quantity');
$itemValue *= $item->get('quantity');
}
$weight += $itemWeight;
$value += $itemValue;
}
my $pounds = int($weight);
my $ounces = sprintf '%3.1f', (16 * ($weight - $pounds));
if ($pounds == 0 && $ounces eq '0.0' ) {
$ounces = 0.1;
}
$value = sprintf '%.2f', $value;
my $destination = $package->[0]->getShippingAddress;
my $country = $self->correctCountry($destination->get('country'));
$packageData{ID} = $packageIndex;
$packageData{Pounds} = [ $pounds ];
$packageData{Ounces} = [ $ounces ];
$packageData{Machinable} = [ 'true' ];
$packageData{MailType} = [ 'Package' ];
if ($self->get('addInsurance')) {
$packageData{ValueOfContents} = [ $value ];
}
$packageData{Country} = [ $country ];
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->get('userId')) {
WebGUI::Error::InvalidParam->throw(error => q{Driver configured without a USPS userId.});
}
if ($cart->getShippingAddress->get('country') eq 'United States') {
WebGUI::Error::InvalidParam->throw(error => q{Driver only handles international 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;
#$cost = scalar @shippableUnits * $self->get('flatFee');
##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;
#warn $returnedXML;
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);
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:
{
IntlRateResponse => {
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->{IntlRateResponse}->{Package} }) {
my $id = $package->{ID};
##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];
my $rate;
SERVICE: foreach my $service (@{ $package->{Service} }) {
next SERVICE unless $service->{ID} eq $self->get('shipType');
$rate = $service->{Postage};
if ($self->get('addInsurance')) {
if (exists $service->{InsComment}) {
WebGUI::Error::Shop::RemoteShippingRate->throw(error => "No insurance because of: ".$service->{InsComment});
}
$rate += $service->{Insurance};
}
}
if (!$rate) {
WebGUI::Error::Shop::RemoteShippingRate->throw(error => 'Selected shipping service not available');
}
if ($unit->[0]->getSku->shipsSeparately) {
##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 correctCountry ( $country )
Correct country names to be compliant with USPS International's ICL.
=cut
sub correctCountry {
my $self = shift;
my $country = shift;
return $country eq q{United Kingdom} ? q{United Kingdom (Great Britain)}
: $country eq q{Congo, the Democratic Republic of the} ? q{Congo, Democratic Republic of the}
: $country eq q{Cocos (Keeling) Islands} ? q{Cocos Island (Australia)}
: $country eq q{Congo} ? q{Congo, Republic of the}
: $country eq q{Christmas Island} ? q{Christmas Island (Australia)}
: $country eq q{Georgia} ? q{Georgia, Republic of}
: $country eq q{Heard and Mc Donald Islands} ? q{Australia}
: $country eq q{Korea (South)} ? q{South Korea}
: $country eq q{Korea, Republic of} ? q{Democratic People's Republic of Korea}
: $country eq q{Lao People's Democratic Republic} ? q{Laos}
: $country eq q{Macedonia} ? q{Macedonia, Republic of}
: $country eq q{Moldova, Republic of} ? q{Moldova}
: $country eq q{Pitcairn} ? q{Pitcairn Island}
: $country eq q{Russian Federation} ? q{Russia}
: $country eq q{Slovakia} ? q{Slovak Republic}
: $country eq q{Tokelau} ? q{Tokelau (Union) Group (Western Samoa)}
: $country eq q{Trinidad} ? q{Trinidad and Tobago}
: $country eq q{Vatican City State (Holy See)} ? q{Vatican City}
: $country eq q{Viet Nam} ? q{Vietnam}
: $country eq q{Virgin Islands (U.S.)} ? q{Virgin Islands U.S.}
: $country;
}
#-------------------------------------------------------------------
=head2 definition ( $session )
This subroutine returns an arrayref of hashrefs, used to validate data put into
the object by the user, and to automatically generate the edit form to show
the user.
=cut
sub definition {
my $class = shift;
my $session = shift;
WebGUI::Error::InvalidParam->throw(error => q{Must provide a session variable})
unless ref $session eq 'WebGUI::Session';
my $definition = shift || [];
my $i18n = WebGUI::International->new($session, 'ShipDriver_USPS');
my $i18n2 = WebGUI::International->new($session, 'ShipDriver_USPSInternational');
tie my %shippingTypes, 'Tie::IxHash';
##Note, these keys are used by buildXML
$shippingTypes{1} = $i18n2->get('express mail international');
$shippingTypes{2} = $i18n2->get('priority mail international');
$shippingTypes{6} = $i18n2->get('global express guaranteed rectangular');
$shippingTypes{7} = $i18n2->get('global express guaranteed non-rectangular');
$shippingTypes{9} = $i18n2->get('priority mail flat rate box');
$shippingTypes{11} = $i18n2->get('priority mail large flat rate box');
$shippingTypes{15} = $i18n2->get('first class mail international parcels');
$shippingTypes{16} = $i18n2->get('priority mail small flat rate box');
tie my %fields, 'Tie::IxHash';
%fields = (
instructions => {
fieldType => 'readOnly',
label => $i18n->get('instructions'),
defaultValue => $i18n->get('usps instructions'),
noFormProcess => 1,
},
userId => {
fieldType => 'text',
label => $i18n->get('userid'),
hoverHelp => $i18n->get('userid help'),
defaultValue => '',
},
shipType => {
fieldType => 'selectBox',
label => $i18n->get('ship type'),
hoverHelp => $i18n->get('ship type help'),
options => \%shippingTypes,
defaultValue => 'PARCEL',
},
addInsurance => {
fieldType => 'yesNo',
label => $i18n->get('add insurance'),
hoverHelp => $i18n->get('add insurance help'),
defaultValue => 0,
},
##Note, if a flat fee is added to this driver, then according to the license
##terms the website must display a note to the user (shop customer) that additional
##fees have been added.
# flatFee => {
# fieldType => 'float',
# label => $i18n->get('flatFee'),
# hoverHelp => $i18n->get('flatFee help'),
# defaultValue => 0,
# },
);
my %properties = (
name => $i18n2->get('U.S. Postal Service, International'),
properties => \%fields,
);
push @{ $definition }, \%properties;
return $class->SUPER::definition($session, $definition);
}
#-------------------------------------------------------------------
=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=IntlRate&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->shipsSeparately) {
push @shippableUnits, [ $item ];
}
else {
my $zip = $item->getShippingAddress->get('code');
if ($item->getShippingAddress->get('country') eq 'United States') {
WebGUI::Error::InvalidParam->throw(error => q{Driver only handles international shipping});
}
push @{ $looseUnits{$zip} }, $item;
}
}
push @shippableUnits, values %looseUnits;
return @shippableUnits;
}
1;

141
lib/WebGUI/Shop/TaxDriver/EU.pm
View file

@ -16,7 +16,6 @@ package WebGUI::Shop::TaxDriver::EU;
use strict;
use SOAP::Lite;
use WebGUI::Content::Account;
use WebGUI::TabForm;
use WebGUI::Utility qw{ isIn };
@ -63,7 +62,7 @@ tie my %EU_COUNTRIES, 'Tie::IxHash', (
EL => 'Greece',
ES => 'Spain',
FI => 'Finland',
FR => 'France ',
FR => 'France',
GB => 'United Kingdom',
HU => 'Hungary',
IE => 'Ireland',
@ -123,9 +122,9 @@ sub addGroup {
#-------------------------------------------------------------------
=head2 addVATNumber ( VATNumber, localCheckOnly )
=head2 addVATNumber ( VATNumber, user, localCheckOnly )
Adds a VAT number to the database. Checks the number through the VIES database. Returns and error message if a
Adds a VAT number to the database for user, using updateVATNumber. Returns and error message if a
validation error occurred. If the number validates undef is returned.
=head3 VATNumber
@ -151,33 +150,25 @@ sub addVATNumber {
my $db = $self->session->db;
my $i18n = WebGUI::International->new( $self->session, 'TaxDriver_EU' );
WebGUI::Error::InvalidParam->throw( 'A VAT number is required' )
unless $number;
WebGUI::Error::InvalidParam->throw( 'The second argument must be an instanciated WebGUI::User object' )
unless ref $user eq 'WebGUI::User';
WebGUI::Error::InvalidParam->throw( 'Visitor cannot add VAT numbers' )
if $user->isVisitor;
# Check number
my $validator = Business::Tax::VAT::Validation->new;
my $numberIsValid = $localCheckOnly ? $validator->local_check( $number ) : $validator->check( $number );
# Number contains syntax error does not exist. Do not write the code to the db.
if ( !$numberIsValid && $validator->get_last_error_code <= 16 ) {
my $result = $self->updateVATNumber( $number, $user, $localCheckOnly );
if ( $result eq 'INVALID' ) {
return $i18n->get('vat number invalid');
}
elsif ( $result eq 'VALID' ) {
return;
}
else {
my $workflow = WebGUI::Workflow::Instance->create( $self->session, {
workflowId => 'taxeurecheckworkflow01',
parameters => {
userId => $user->userId,
vatNumber => $number,
},
} )->start();
# Write the code to the db.
$db->write( 'replace into tax_eu_vatNumbers (userId,countryCode,vatNumber,viesValidated,viesErrorCode,approved) values (?,?,?,?,?,?)', [
$user->userId,
substr( $number, 0 , 2 ),
$number,
$numberIsValid ? 1 : 0,
$numberIsValid ? undef : $validator->get_last_error_code,
0,
] );
return $numberIsValid ? undef : $i18n->get('vies unavailable');
return $i18n->get('vies unavailable');
}
}
#-------------------------------------------------------------------
@ -824,6 +815,33 @@ sub isUsableVATNumber {
#-------------------------------------------------------------------
=head2 recheckVATNumber ( vatNumber, user )
Uses updateVATNumber to check and store the given number for the given user. Returns INVALID od VALID for invalid
and valid number respectively. If VIES is unavailable returns UNKNOWN.
=head3 vatNumber
The VAT number to be rechecked.
=head3 user
An instanciated WebGUI::User object for the user belonging to the VAT number.
=cut
sub recheckVATNumber {
my $self = shift;
my $number = shift;
my $user = shift || $self->session->user;
my $result = $self->updateVATNumber( $number, $user );
return $result;
}
#-------------------------------------------------------------------
=head2 skuFormDefinition ( )
Returns a hash ref containing the form definition for the per sku options for this tax driver.
@ -855,6 +873,73 @@ sub skuFormDefinition {
#-------------------------------------------------------------------
=head2 updateVATNumber( VATNumber, user, localCheckOnly )
Validates the VAT number with the VIES service. If the number is incorrect, INVALID will be returned. Otherwise the
number is added to the db. If the number cannot be validated 'UNKNOWN' is returned, if the number is valid 'VALID'
will be returned.
=head3 VATNumber
The number that is to be added.
=head3 user
The user for which the number should be added. Defaults to the session user.
=head3 localCheckOnly
If set to a true value the the remote VAT number validation in the VIES database will not be preformed. The VAT
number will be checked against regexes, however. Mostly convenient for testing purposes.
=cut
sub updateVATNumber {
my $self = shift;
my $number = shift;
my $user = shift || $self->session->user;
my $localCheckOnly = shift;
my $db = $self->session->db;
WebGUI::Error::InvalidParam->throw( 'A VAT number is required' )
unless $number;
WebGUI::Error::InvalidParam->throw( 'The second argument must be an instanciated WebGUI::User object' )
unless ref $user eq 'WebGUI::User';
WebGUI::Error::InvalidParam->throw( 'Visitor cannot add VAT numbers' )
if $user->isVisitor;
# Check number
my $validator = Business::Tax::VAT::Validation->new;
my $numberIsValid = $localCheckOnly ? $validator->local_check( $number ) : $validator->check( $number );
# Number contains syntax error does not exist. Do not write the code to the db.
if ( !$numberIsValid && $validator->get_last_error_code <= 16 ) {
$self->deleteVATNumber( $number, $user );
return 'INVALID';
}
# Write the code to the db.
$db->write( 'replace into tax_eu_vatNumbers (userId,countryCode,vatNumber,viesValidated,viesErrorCode,approved) values (?,?,?,?,?,?)', [
$user->userId,
substr( $number, 0 , 2 ),
$number,
$numberIsValid ? 1 : 0,
$numberIsValid ? undef : $validator->get_last_error_code,
0,
] );
if ( $numberIsValid ) {
return 'VALID';
}
else {
return 'UNKNOWN';
}
}
#-------------------------------------------------------------------
=head2 www_addGroup
Adds a VAT group.

42
lib/WebGUI/Shop/Transaction.pm
View file

@ -619,6 +619,48 @@ sub newByGatewayId {
#-------------------------------------------------------------------
=head2 sendNotifications ( transaction )
Sends out a receipt and a sale notification to the buyer and the store owner respectively.
=cut
sub sendNotifications {
my ($self) = @_;
my $session = $self->session;
my $i18n = WebGUI::International->new($session, 'PayDriver');
my $url = $session->url;
my $var = $self->getTransactionVars;
# render
my $template = WebGUI::Asset::Template->new( $session, $session->setting->get("shopReceiptEmailTemplateId") );
my $inbox = WebGUI::Inbox->new($session);
my $receipt = $template->process( $var );
WebGUI::Macro::process($session, \$receipt);
# purchase receipt
$inbox->addMessage( {
message => $receipt,
subject => $i18n->get('receipt subject') . ' ' . $self->get('orderNumber'),
userId => $self->get('userId'),
status => 'completed',
} );
# shop owner notification
# Shop owner uses method=view rather than method=viewMy
$var->{viewDetailUrl} = $url->page( 'shop=transaction;method=view;transactionId='.$self->getId, 1 );
my $notification = $template->process( $var );
WebGUI::Macro::process($session, \$notification);
$inbox->addMessage( {
message => $notification,
subject => $i18n->get('a sale has been made') . ' ' . $self->get('orderNumber'),
groupId => $session->setting->get('shopSaleNotificationGroupId'),
status => 'unread',
} );
}
#-------------------------------------------------------------------
=head2 thankYou ()
Displays the default thank you page.

7
lib/WebGUI/Shop/TransactionItem.pm
View file

@ -265,7 +265,8 @@ The status of this item. The default is 'NotShipped'. Other statuses include: Ca
sub update {
my ($self, $newProperties) = @_;
my $id = id $self;
my $session = $self->transaction->session;
my $transaction = $self->transaction;
my $session = $transaction->session;
my $taxDriver = WebGUI::Shop::Tax->getDriver( $session );
if (exists $newProperties->{item}) {
@ -296,7 +297,7 @@ sub update {
$newProperties->{ taxConfiguration } =
to_json( $taxDriver->getTransactionTaxData( $sku, $address ) || '{}' );
unless ($sku->isShippingRequired) {
if (!$sku->isShippingRequired && $transaction->get('isSuccessful')) {
$newProperties->{orderStatus} = 'Shipped';
}
}
@ -310,7 +311,7 @@ sub update {
if (exists $newProperties->{options} && ref($newProperties->{options}) eq "HASH") {
$properties{$id}{options} = JSON->new->encode($newProperties->{options});
}
$properties{$id}{lastUpdated} = WebGUI::DateTime->new($self->transaction->session,time())->toDatabase;
$properties{$id}{lastUpdated} = WebGUI::DateTime->new($session,time())->toDatabase;
$self->transaction->session->db->setRow("transactionItem","itemId",$properties{$id});
}

27
lib/WebGUI/Shop/Vendor.pm
View file

@ -303,7 +303,7 @@ The name of the vendor.
=head4 userId
The name of the vendor.
The unique GUID of the vendor.
=head4 url
@ -588,16 +588,26 @@ Returns the status to which the item(s) are set.
=cut
sub www_setPayoutStatus {
my $class = shift;
my $session = shift;
my $class = shift;
my $session = shift;
my ( $form, $db ) = $session->quick( qw{ form db } );
my $admin = WebGUI::Shop::Admin->new($session);
return $session->privilege->adminOnly() unless ($admin->canManage);
my @itemIds = $session->form->process('itemId');
my $status = $session->form->process('status');
my $status = $form->process('status');
return "error: wrong status [$status]" unless isIn( $status, qw{ NotPaid Scheduled } );
my @itemIds;
if ( $form->process( 'all' ) ) {
@itemIds = $session->db->buildArray( 'select itemId from transactionItem where vendorPayoutStatus = ?' , [
( $status eq 'NotPaid' ) ? 'Scheduled' : 'NotPaid'
] );
}
else {
@itemIds = $form->process('itemId');
}
foreach my $itemId (@itemIds) {
my $item = WebGUI::Shop::TransactionItem->newByDynamicTransaction( $session, $itemId );
return "error: invalid transactionItemId [$itemId]" unless $item;
@ -677,10 +687,13 @@ sub www_vendorTotalsAsJSON {
foreach my $vendorId (keys %{ $vendorPayoutData }) {
my $vendor = WebGUI::Shop::Vendor->new( $session, $vendorId );
push @dataset, {
my $dataset = {
%{ $vendor->get },
%{ $vendorPayoutData->{ $vendorId } },
}
};
my $user = WebGUI::User->new($session, $vendor->get('userId'));
$dataset->{name} .= ' ('.$user->username.')';
push @dataset, $dataset;
}
$session->http->setMimeType( 'application/json' );