File Coverage

blib/lib/Business/FedEx/DirectConnect.pm

Criterion	Covered	Total	%
statement	15	190	7.8
branch	0	90	0.0
condition	0	29	0.0
subroutine	5	22	22.7
pod	13	14	92.8
total	33	345	9.5

# FedEx::DirectConnect
# $Id: DirectConnect.pm,v 1.27 2004/08/09 16:07:20 jay.powers Exp $
# Copyright (c) 2004 Jay Powers
# All rights reserved.
#
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself

package Business::FedEx::DirectConnect; #must be in Business/FedEx

require 5.006_000;

use Business::FedEx::Constants qw(
    %FE_RE %FE_SE %FE_TT %FE_RQ
    field_name_to_tag
    field_tag_to_name
);

use Carp qw(confess croak);
use LWP::UserAgent;

our $VERSION = '1.01';

use strict;


#Please register with FedEx to receive the addresses to their DirectConnect API.
use constant FEDEX_API_URI => '';

# Use Tie::IxHash so that fields are output in the order they're set,
# which makes reading the list of fields easier if you set them in a
# useful order.
#
# XXX only use IxHash when a debug flag is set?

{ my $have_ix_hash;
sub _init_ix_hash {
    my ($rhash, $rdata) = @_;

    $have_ix_hash = !!eval { local $SIG{__DIE__}; require Tie::IxHash }
    if !defined $have_ix_hash;

    if ($have_ix_hash) {
    tie %$rhash, 'Tie::IxHash', @$rdata;
    }
    else {
        %$rhash = @$rdata;
    }
} }

sub new {
    my $name = shift;
    my $class = ref($name) || $name;
    my $self  = {
                 uri=>FEDEX_API_URI
                ,acc => ''
                ,meter => ''
                ,referer => ''
                ,Debug=>0
                ,sdata => {}
                ,@_ };
    $self->{UA} = LWP::UserAgent->new(
                          exists $self->{timeout}
                              ? (timeout => $self->{timeout})
                              : ()
                    );
    $self->{REQ} = HTTP::Request->new(POST => $self->{uri}); # Create a request
    bless ($self, $class);
}

sub get_data {
    my $self = shift;
    my @key = @_;

    if (!@key) {
        return $self->{sdata};
    }

    if (@key > 1 && !wantarray) {
        croak "scalar context but asked for ", 0+@key, " items";
    }

    my $r = $self->{sdata};
    my @ret;
    for my $key (@key) {
        # This sucks, but the key might be present as either a number
        # or a name (or both, there's nothing which prevents that
        # currently).
        #
        # Check first as they passed it (in case it's there both ways):

        #print "key=$key\n";
        if (exists $r->{$key}) {
            push @ret, $r->{$key};
            next;
        }

        # Then as a number:

        my $tag = field_name_to_tag $key;
        #print "tag=$tag\n";
        if (exists $r->{$tag}) {
            push @ret, $r->{$tag};
            next;
        }

        # Then as a name:

        my $name = field_tag_to_name $key;
        #print "name=$name\n";
        if (exists $r->{$name}) {
            push @ret, $r->{$name};
            next;
        }

        # It isn't there.

        print "undef\n";
        push @ret, undef;
    }

    return wantarray ? @ret : $ret[0];
}

sub set_data {
    my $self = shift;
    $self->{UTI} = shift;
    $self->{sdata} = {};
    _init_ix_hash $self->{sdata}, \@_;
    if (!$self->{UTI}) {
        $self->set_err("Error: You must provide a valid UTI.");
        return 0;
    }
    $self->{sbuf} = '0,"' . $FE_TT{$self->{UTI}}[0] . '"';

    # Supply default values where appropriate.

    for ([3025 => $FE_TT{$self->{UTI}}[1]]
            , [10 => $self->{acc}]
            , $self->{UTI} == 3003 ? () : [498 => $self->{meter}]
            ) {
        my ($key, $val) = @$_;
        $self->{sdata}->{$key} = $val
            unless exists $self->{sdata}->{$key};
    }

    while (my ($key, $val) = each %{$self->{sdata}}) {
        $key = field_name_to_tag $key;

        # Empty value should not be sent (except for 99).

        next if !defined $val;
        next if $val !~ /\S/;

        # Alphanumeric fields should not contain leading or
        # trailing blanks.

        $val =~ s/^\s+//;
        $val =~ s/\s+\z//;

        # %-escape as necessary

        $val =~ s/([%"\x00])/sprintf '%%%02X', ord $1/eg;

        # XXX The TT guide says the data needs to be ASCII only (though
        # it didn't choke on Latin 1 chars I tried sending it), but
        # there's no way for me to do the translation here since I don't
        # know what char set you're using.  Croak if there are non-ASCII
        # data?

        $self->{sbuf} .= qq($key,"$val");
    }
    $self->{sbuf} .= '99,""';
    return $self->{sbuf};
}

# Send a call to FedEx
sub transaction {
    my $self = shift;
    if (@_) {
        $self->{sbuf} = shift;
    }
    if (!$self->{sbuf}) {
        $self->set_err("Error: You must provide data to send to FedEx.");
        return 0;
    }

    if ($self->_send())    { # send POST to FedEx
        $self->{rbuf} =~ s/[\x00\s]+$//g; # get rid of the extra spaces/nulls
        $self->{rstring} = "Total bytes returned ". length($self->{rbuf}) if ($self->{Debug});
        print $self->{rstring} . "\n" if ($self->{Debug});
        $self->{rHash} = $self->_split_data()
            or return 0;
        # Check for Errors from FedEx
        if (exists $self->{rHash}->{2}) {
            $self->set_err("FedEx Transaction Error: " . $self->{rHash}->{2} . " " . $self->{rHash}->{3},
                            $self->{rHash}->{2});
            return 0;
        }
        return 1;
    } else {
        return 0;
    }
}


# Send POST request to FedEx API
sub _send {
    my $self = shift;
    print "Sending ". $self->{sbuf} . "\n" if ($self->{Debug});
    $self->{REQ}->header(()
    ,'Referer' => $self->{referer}
    ,'User-Agent' => 'Business-FedEx-DirectConnect-'.$VERSION
    ,'Accept' => "image/gif,image/jpeg,image/pjpeg,text/plain,text/html,*/*"
    ,'Content-Type' => "image/gif"
    ,'Content-Length' => length($self->{sbuf}));
    $self->{sbuf} .= '99,""' unless ($self->{sbuf} =~ /99,\"\"$/);
    $self->{REQ}->content($self->{sbuf});
    print $self->{REQ}->as_string() if ($self->{Debug});
    # Pass request to the user agent and get a response back
    my $res = $self->{UA}->request($self->{REQ});
    # Check the outcome of the response
    if ($res->is_success) {
        $self->{rbuf} = $res->content;
        return 1;
    } else {
        $self->set_err("Request Error: " . $res->status_line);
        return 0;
    }
}

# here are some functions to deal with data from FedEx
sub _split_data {
    my $self = shift;
    my $sdata = shift || $self->{rbuf};
    my $count = 0;
    my (%hash, @key);

    if (!defined $sdata) {
        $self->set_err("No data received from FedEx server");
        return;
    }

    # There ought to be a way to signal less serious errors without
    # choking completely, or a way for the user to tell you to notice
    # them.

    my $warn = 0;

    while ($sdata ne '') {
        if ($sdata !~ s/^(0|[1-9]\d*(?:-\d*)*),"([^"]*)"//) {
            $self->set_err("Invalid FedEx transaction data at `$sdata'");
            return;
        }
        my ($key, $val) = ($1, $2);

        if (exists $hash{$key}) {
            $self->set_err("Duplicate key $key in FedEx transaction");
            return;
        }

        if ($warn && $val eq '' && $key ne '99') {
            $self->set_err("Empty value for key $key in FedEx transaction");
            return;
        }

        push @key, $key;
        $hash{$key} = $val;
    }

    if ($warn && $key[0] ne '0') {
        $self->set_err("first element of FedEx transaction data isn't 0");
        return;
    }

    if ($warn && $key[-1] ne '99') {
        $self->set_err("last element of FedEx transaction data isn't 99");
        return;
    }

    if ($warn && $hash{99} ne '') {
        $self->set_err("non-empty value for last element of FedEx transaction data");
        return;
    }

    # XXX validate \d+-\d+ type fields

    return \%hash;
}


# array of all the required fields
sub required {
    my $self = shift;
    my $uti = shift;
    my @req;
    foreach (@{$FE_RQ{$uti}}) {
        push (@req, $FE_RE{$_});
    }
    return @req;
}

#check against required fields
# XXX Why are you passing in the UTI instead of using $self->{UTI}?
sub has_required {
    my $self = shift;
    my $uti = shift;
    my @keys = keys %{$self->{sdata}};
    my (%seen, @diff);
    @seen{@keys} = ();
    # XXX 0 is in %FE_RQ but not in sdata
    $seen{0} = undef;
    foreach (@{$FE_RQ{$uti}}) {
        push(@diff, $_) unless exists $seen{$_};
    }
    return @diff
}
# print or create a label
sub label {
    my $self = shift;
    my $file = shift;
    my $image_key = shift || 188;
    $self->{rbinary} = $self->{rHash}->{$image_key};
    $self->{rbinary} =~ s/\%([0-9A-F][0-9A-F])/chr(hex("0x$1"))/eg if ($self->{rbinary});
    if ($file) {
        open(FILE, ">$file") or die "Could not open $file:\n$!";
        binmode(FILE);
        print FILE $self->{rbinary};
        close(FILE);
        return 1;
    } else {
        return $self->{rbinary};
    }
}
#look up a value
sub lookup {
    my $self = shift;
    my $code = field_name_to_tag shift;
    print "Looking for " . $code . "\n" if ($self->{Debug});
    return $self->{rHash}->{$code};
}
# All the data from FedEx
sub rbuf {
    my $self = shift;
    $self->{rbuf} = shift if @_;
    return $self->{rbuf};
}
# Build a hash from the return data from FedEx
sub hash_ret {
    my $self = shift;
    return $self->{rHash};
}

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

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

sub set_err {
    my $self = shift;
    my $errstr = @_ ? shift : "Unknown error";
    my $errcode = @_ ? shift : -1;
    @_ and confess;

    $self->errstr($errstr);
    $self->errcode($errcode);
}

sub user_data {
    @_ == 1 || @_ == 2
        or croak "->user_data expected 0 or 1 args, got ", 0+@_;
    my $self = shift;
    my $old = $self->{user_data};
    $self->{user_data} = shift if @_;
    return $old;
}

1;
__END__