File Coverage

blib/lib/Business/FedEx/RateRequest.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package Business::FedEx::RateRequest;

use 5.008008;
use strict;
use warnings;

require Exporter;

use LWP::UserAgent;
use XML::Simple;
use Data::Dumper;

 use Time::Piece;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Business::FedEx::RateRequest ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw();

our $VERSION = '1.00';

# FedEx Shipping notes
our %ship_note;
$ship_note{'FEDEX SAMEDAY'} = 'Fastest Delivery time based on flight availability';
$ship_note{'FIRST_OVERNIGHT'} = 'Overnight Delivery by 8:00 or 8:30 am';
$ship_note{'PRIORITY_OVERNIGHT'} = 'Overnight Delivery by 10:30 am';
$ship_note{'STANDARD_OVERNIGHT'} = 'Overnight Delivery by 3:00 pm';
$ship_note{'FEDEX_2_DAY'} = '2 Business Days Delivery by 4:30 pm';
$ship_note{'FEDEX_EXPRESS_SAVER'} = '3 Business Days Delivery by 4:30 pm';
$ship_note{'FEDEX_GROUND'} = '1-5 Business Days Delivery day based on distance to destination';
$ship_note{'FEDEX_HOME_DELIVERY'} = '1-5 Business Days Delivery day based on distance to destination';

$ship_note{'INTERNATIONAL_NEXT_FLIGHT'} = 'Fastest Delivery time based on flight availability';
$ship_note{'INTERNATIONAL_FIRST'}   = '2 Business Days Delivery by 8:00 or 8:30 am to select European cities';
$ship_note{'INTERNATIONAL_PRIORITY'}= '1-3 Business Days Delivery time based on country';
$ship_note{'INTERNATIONAL_ECONOMY'} = '2-5 Business Days Delivery time based on country';
$ship_note{'INTERNATIONAL_GROUND'}	= '3-7 Business Days Delivery to Canada and Puerto Rico';

# Preloaded methods go here.

sub new {

    my $name = shift;
    my $class = ref($name) || $name;

    my %args = @_;

    my $self  = {
                 uri => $args{'uri'},
                 account  => $args{'account'},
                 meter    =>  $args{'meter'},
                 key      =>  $args{'key'},
                 password =>  $args{'password'},
                 err_msg =>    "",
                };

    my @rqd_lst = qw/uri meter account key password/;
    foreach my $param (@rqd_lst) { unless ( $args{$param} ) { $self->{'err_msg'}="$param required"; return 0; } }

    $self->{UA} = LWP::UserAgent->new(agent => 'perlworks');
    if ( $args{'timeout'} ) { $self->{UA}->timeout($args{'timeout'}); }

    #$self->{REQ} = HTTP::Request->new(POST=>$self->{uri}); # Create a request

    bless ($self, $class);
}

# - - - - - - - - - - - - - - -
sub get_rates
{
   my $self = shift @_;
   my %args = @_;

   # As of Jan 2014 Fedex without warning changed the return xml document. The elements with versionized name spaces were changed to generic tags.
   # so what was  is now   Sheessssh why would they change something like this....

   my $ver_prefix = '';  # Added a version namespace prefix in case they add it back in at a latter date.

   my @rqd_lst = qw/src_zip dst_zip weight/;
   foreach my $param (@rqd_lst) { unless ( $args{$param} ) { $self->{'err_msg'}="$param required"; return 0; } }

   unless ( $args{'src_country'}    ) { $args{'src_country'} = 'US' }
   unless ( $args{'dst_country'}    ) { $args{'dst_country'} = 'US' }
   unless ( $args{'dst_residential'}) { $args{'dst_residential'} = 'false' }
   unless ( $args{'weight_units'}   ) { $args{'weight_units'} = 'LB'}
   unless ( $args{'size_units'}     ) { $args{'size_units'} = 'IN' }
   unless ( $args{'length'}         ) { $args{'length'} = '5' }
   unless ( $args{'width'}          ) { $args{'width'}  = '5' }
   unless ( $args{'height'}         ) { $args{'height'} = '5' }
   unless ( $args{'dropoff_type'}   ) { $args{'dropoff_type'} = 'REGULAR_PICKUP' }
   unless ( $args{'insured_value'}  ) { $args{'insured_value'} = '0' }

   my $datetime = localtime;
   $args{'timestamp'} = $datetime->datetime;

   my $xml_snd_doc = $self->gen_xml_v9(\%args);
   #my $xml_snd_doc = $self->gen_xml_v10(\%args);

   #-#print $xml_snd_doc; exit; # debug line

   my $response = $self->{UA}->post($self->{'uri'}, Content_Type=>'text/xml', Content=>$xml_snd_doc);

   unless ($response->is_success)
   {
	  $self->{'err_msg'} = "Error Request: " . $response->status_line;
      return 0;
   }

   # Must be success let's parse

   my $rtn = $response->as_string;
   $rtn =~ /(.*)\n\n(.*)/s;

   my $hdr = $1;  # Don't use for anything right now
   my $xml_rtn_doc = $2; # The object of this all....

   my $xml_obj  = new XML::Simple;

   my $data = $xml_obj->XMLin($xml_rtn_doc); # Time consuming operation. could use a regexp to speed up if necessary.

   #-#print $response->as_string; exit; # Debug line

   my $rate_lst_ref = $data->{"${ver_prefix}RateReplyDetails"};

   my @rtn_lst; # This will be returned

   unless ( defined $rate_lst_ref )
   {
       $self->{'err_msg'} = $data->{faultstring} || 'No rate data returned';
       return 0;
   } # Kyle's catch

   # If only one rate service
   if ( ref $rate_lst_ref eq 'HASH' ) { $rate_lst_ref = [ $rate_lst_ref ] }

   my $i = 0;
   foreach my $detail_ref ( @{$rate_lst_ref} )
   {
      my $ah_ref = $detail_ref->{"${ver_prefix}RatedShipmentDetails"};
      my $ship_cost;

      if ( ref($ah_ref) eq 'ARRAY' )
      {
			$ship_cost = $ah_ref->[0]->{"${ver_prefix}ShipmentRateDetail"}->{"${ver_prefix}TotalNetCharge"}->{"${ver_prefix}Amount"};
      }
      else
	  {
	        $ship_cost = $ah_ref->{"${ver_prefix}ShipmentRateDetail"}->{"${ver_prefix}TotalNetCharge"}->{"${ver_prefix}Amount"};
      }

  	  my $ServiceType = $detail_ref->{"${ver_prefix}ServiceType"};

      # Tags
      my $tag = lc($ServiceType);
      $tag =~ s/_/ /g;
      $tag =~ s/\b(\w)/\U$1/g;

	  # Notes
      my $note = $ship_note{"$ServiceType"};

      $rtn_lst[$i] = {'ServiceType'=>$ServiceType, 'ship_cost'=>$ship_cost, 'ship_tag'=>$tag, 'ship_note'=>$note};
      $i++;
   }

   return wantarray ? @rtn_lst : \@rtn_lst;
 }

# - - - - - - - - - - - - - - -
sub gen_xml_v10
{
   my $self = shift;
	my $args = shift;

	my $rqst = qq(




$self->{'key'}
$self->{'password'}



$self->{'account'}
$self->{'meter'}


Rate a Single Package V10


crs
10
0
0

1
FDXE

$args->{'timestamp'}
$args->{'dropoff_type'}
YOUR_PACKAGING

$self->{'account'}

PERSONAL_STATE
1057
ShipperTinsUsage


SY32030
Sunil Yadav
Syntel Inc
9545871684
020
sunil_yadav3\@syntelinc.com


SHIPPER ADDRESS LINE 1
SHIPPER ADDRESS LINE 2
COLORADO SPRINGS
CO
$args->{'src_zip'}
CO
$args->{'src_country'}
0




Receipient
Receiver Org
9982145555
011
receiver\@yahoo.com


RECIPIENT ADDRESS LINE 1
RECIPIENT ADDRESS LINE 2
DENVER
CO
$args->{'dst_zip'}
CO
$args->{'dst_country'}
0


DEN001


SY32030
Sunil Yadav
Syntel Inc
9545871684
020
sunil_yadav3\@syntelinc.com


SHIPPER ADDRESS LINE 1
SHIPPER ADDRESS LINE 2
COLORADO SPRINGS
CO
80915
CO
US
0



SENDER


US


ACCOUNT
1

1
1
1

$args->{'weight_units'}
$args->{'weight'}


$args->{'length'}
$args->{'width'}
$args->{'height'}
$args->{'size_units'}

BAG

PRTNMBR007
ITMNMBR007
10
ContentDescription




);

  #$rqst =~ s/\n//g;
  return $rqst;
}

# - - - - - - - - - - - - - - -
sub gen_xml_v9
{
   my $self = shift;
	my $args = shift;

	my $rqst = <




      $self->{'key'}
      $self->{'password'}



    $self->{'account'}
    $self->{'meter'}


    Perlworks


    crs
    9
    0
    0


    $args->{'timestamp'}
    $args->{'dropoff_type'}
    YOUR_PACKAGING

        USD
        $args->{'insured_value'}


      $self->{'account'}

        $args->{'src_zip'}
        $args->{'src_country'}




        $args->{'dst_zip'}
        $args->{'dst_country'}
        $args->{'dst_residential'}



      SENDER

        $self->{'account'}
        USD


    ACCOUNT
    1
    INDIVIDUAL_PACKAGES

      1

        $args->{'weight_units'}
        $args->{'weight'}


        $args->{'length'}
        $args->{'width'}
        $args->{'height'}
        $args->{'size_units'}




END

  #$rqst =~ s/\n//g;
  return $rqst;
}

sub err_msg
{
  my $self = shift @_;
  return $self->{err_msg};
}


# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__