File Coverage

blib/lib/Business/TNT/ExpressConnect.pm
Criterion Covered Total %
statement 21 23 91.3
branch n/a
condition n/a
subroutine 8 8 100.0
pod n/a
total 29 31 93.5


line stmt bran cond sub pod time code
1             package Business::TNT::ExpressConnect;
2              
3 1     1   649 use 5.010;
  1         2  
4 1     1   3 use strict;
  1         1  
  1         16  
5 1     1   8 use warnings;
  1         1  
  1         39  
6              
7             our $VERSION = '0.01';
8              
9 1     1   449 use Path::Class qw(dir file);
  1         26032  
  1         51  
10 1     1   443 use Config::INI::Reader;
  1         26078  
  1         34  
11 1     1   553 use LWP::UserAgent;
  1         27927  
  1         29  
12 1     1   491 use Moose;
  1         287307  
  1         6  
13 1     1   5225 use XML::Compile::Schema;
  0            
  0            
14             use XML::Compile::Util qw/pack_type/;
15             use DateTime;
16              
17             use Business::TNT::ExpressConnect::SPc;
18              
19             has 'user_agent' => (is => 'ro', lazy_build => 1);
20             has 'config' => (is => 'ro', lazy_build => 1);
21             has 'username' => (is => 'ro', lazy_build => 1);
22             has 'password' => (is => 'ro', lazy_build => 1);
23             has 'xml_schema' => (is => 'ro', lazy_build => 1);
24             has 'error' => (is => 'rw', isa => 'Bool', default => 0);
25             has 'errors' => (is => 'rw', isa => 'ArrayRef[Str]');
26             has 'warnings' => (is => 'rw', isa => 'ArrayRef[Str]');
27              
28             sub _build_user_agent {
29             my ($self) = @_;
30              
31             my $user_agent = LWP::UserAgent->new;
32             $user_agent->timeout(30);
33             $user_agent->env_proxy;
34              
35             return $user_agent;
36             }
37              
38             sub _build_config {
39             my ($self) = @_;
40              
41             my $config_filename =
42             file(Business::TNT::ExpressConnect::SPc->sysconfdir, 'tnt-expressconnect.ini');
43              
44             unless (-r $config_filename) {
45             $self->warnings(['could not read config file '.$config_filename]);
46             return {};
47             }
48              
49             return Config::INI::Reader->read_file($config_filename);
50             }
51              
52             sub _build_username {
53             my ($self) = @_;
54              
55             return $self->config->{_}->{username};
56             }
57              
58             sub _build_password {
59             my ($self) = @_;
60              
61             return $self->config->{_}->{password};
62             }
63              
64             sub _build_xml_schema {
65             my ($self) = @_;
66              
67             my $xsd_file = $self->_price_request_common_xsd;
68             my $xml_schema = XML::Compile::Schema->new($xsd_file);
69              
70             return $xml_schema;
71             }
72              
73             sub _xsd_basedir {
74             dir(Business::TNT::ExpressConnect::SPc->datadir, 'tnt-expressconnect', 'xsd', 'pricing', 'v3');
75             }
76              
77             sub _price_request_in_xsd {
78             my $file = _xsd_basedir->file('PriceRequestIN.xsd');
79              
80             die "cannot read request IN xsd file " . $file unless (-r $file);
81              
82             return $file;
83             }
84              
85             sub _price_request_out_xsd {
86             my ($self) = @_;
87             my $file = _xsd_basedir->file('PriceResponseOUT.xsd');
88              
89             die "cannot read request OUT xsd file " . $file unless (-r $file);
90              
91             return $file;
92             }
93              
94             sub _price_request_common_xsd {
95             my ($self) = @_;
96              
97             my $file = _xsd_basedir->file('commonDefinitions.xsd');
98              
99             die "cannot read common definitions xsd file " . $file unless (-r $file);
100              
101             return $file;
102             }
103              
104             sub tnt_get_price_url {
105             return 'https://express.tnt.com/expressconnect/pricing/getprice';
106             }
107              
108             sub hash_to_price_request_xml {
109             my ($self, $params) = @_;
110              
111             my $xml_schema = $self->xml_schema;
112             $xml_schema->importDefinitions($self->_price_request_in_xsd);
113              
114             # create and use a writer
115             my $doc = XML::LibXML::Document->new('1.0', 'UTF-8');
116             my $write = $xml_schema->compile(WRITER => '{}priceRequest');
117              
118             my %priceCheck = (
119             rateId => 1, #unique within priceRequest
120             sender => $params->{sender},
121             delivery => $params->{delivery},
122             collectionDateTime => ($params->{collection_datetime} // DateTime->now()),
123             currency => ($params->{currency} // 'EUR'),
124             product => {type => ($params->{product_type} // 'N')}
125             , #“D” Document(paper/manuals/reports) or “N” Non-document (packages)
126             );
127              
128             $priceCheck{consignmentDetails} = $params->{consignmentDetails}
129             if ($params->{consignmentDetails});
130             $priceCheck{pieceLine} = $params->{pieceLine} if ($params->{pieceLine});
131              
132             my %hash = (appId => 'PC', appVersion => '3.0', priceCheck => [\%priceCheck]);
133             my $xml = $write->($doc, \%hash);
134             $doc->setDocumentElement($xml);
135              
136             return $doc;
137             }
138              
139             sub get_prices {
140             my ($self, $args) = @_;
141              
142             my $user_agent = $self->user_agent;
143             my $req = HTTP::Request->new(POST => $self->tnt_get_price_url);
144             $req->authorization_basic($self->username, $self->password);
145             $req->header('Content-Type' => 'text/xml; charset=utf-8');
146              
147             if (my $file = $args->{file}) {
148             $req->content('' . file($file)->slurp);
149              
150             }
151             elsif (my $params = $args->{params}) {
152             my $xml = $self->hash_to_price_request_xml($params);
153             $req->content($xml->toString(1));
154              
155             }
156             else {
157             $self->error(1);
158             $self->errors(['missing price request data']);
159             return undef;
160             }
161              
162             my $response = $user_agent->request($req);
163              
164             if ($response->is_error) {
165             $self->error(1);
166             $self->errors(['Request failed: ' . $response->status_line]);
167             return undef;
168             }
169              
170             my $response_xml = $response->content;
171              
172             #parse schema
173             my $xml_schema = $self->xml_schema;
174             $xml_schema->importDefinitions($self->_price_request_out_xsd);
175              
176             #read xml file
177             my $elem = XML::Compile::Util::pack_type '', 'document';
178             my $read = $xml_schema->compile(READER => $elem);
179              
180             my $data = $read->($response_xml);
181              
182             my @errors;
183             my @warnings;
184             foreach my $error (@{$data->{errors}->{brokenRule}}) {
185             if ($error->{messageType} eq "W") {
186             push @warnings, $error->{description};
187             } else {
188             push @errors, $error->{description};
189             }
190             }
191              
192             if (@warnings) {
193             $self->warnings(\@warnings);
194             }
195             if (@errors) {
196             $self->error(1);
197             $self->errors(\@errors);
198             return undef;
199             }
200              
201             my $ratedServices = $data->{priceResponse}->[0]->{ratedServices};
202             my $currency = $ratedServices->{currency};
203             my $ratedService = $ratedServices->{ratedService};
204              
205             my %prices;
206             my $i = 0;
207             foreach my $option (@$ratedService) {
208             $prices{$option->{product}->{id}} = {
209             price_desc => $option->{product}->{productDesc},
210             currency => $currency,
211             total_price => $option->{totalPrice},
212             total_price_excl_vat => $option->{totalPriceExclVat},
213             vat_amount => $option->{vatAmount},
214             charge_elements => $option->{chargeElements},
215             sort_index => $i++,
216             };
217             }
218              
219             return \%prices;
220             }
221              
222             sub http_ping {
223             my ($self) = @_;
224             my $response = $self->user_agent->get($self->tnt_get_price_url);
225              
226             return 1 if $response->code == 401;
227             return 0;
228             }
229              
230             1;
231              
232             __END__
233              
234             =head1 NAME
235              
236             Business::TNT::ExpressConnect - TNT ExpressConnect interface
237              
238             =head1 SYNOPSIS
239              
240             # read config from config file
241             my $tnt = Business::TNT::ExpressConnect->new();
242              
243             # provide username and password
244             my $tnt = Business::TNT::ExpressConnect->new({username => 'john', password => 'secret'});
245              
246             # use xml file to define the request
247             my $tnt_prices = $tnt->get_prices({file => $xml_filename});
248              
249             #use a hash to define the request
250             my %params = (
251             sender => {country => 'AT', town => 'Vienna', postcode => 1020},
252             delivery => {country => 'AT', town => 'Schwechat', postcode => '2320'},
253             consignmentDetails => {
254             totalWeight => 1.25,
255             totalVolume => 0.1,
256             totalNumberOfPieces => 1
257             }
258             );
259              
260             $tnt_prices = $tnt->get_prices({params => \%params});
261              
262             warn join("\n",@{$tnt->errors}) unless ($tnt_prices);
263              
264             # tnt prices structure
265             $tnt_prices = {
266             '10' => {
267             'charge_elements' => 'HASH(0x40a5f40)',
268             'total_price_excl_vat' => '96.14',
269             'vat_amount' => '19.23',
270             'price_desc' => '10:00 Express',
271             'total_price' => '115.37',
272             'sort_index' => 1,
273             'currency' => 'EUR'
274             },
275             '09' => {
276             'currency' => 'EUR',
277             'sort_index' => 0,
278             'charge_elements' => 'HASH(0x40b0130)',
279             'total_price_excl_vat' => '101.79',
280             'vat_amount' => '20.36',
281             'total_price' => '122.15',
282             'price_desc' => '9:00 Express'
283             },
284             };
285              
286              
287             =head1 DESCRIPTION
288              
289             Calculate prices for TNT delivery.
290              
291             Schema definitions and user guides: https://express.tnt.com/expresswebservices-website/app/pricingrequest.html
292              
293             =head1 CONFIGURATION
294              
295             =head2 etc/tnt-expressconnect.ini
296              
297             username = john
298             password = secret
299              
300             =head1 METHODS
301              
302             =head2 get_prices(\%hash)
303              
304             get_prices({file => $filename}) or get_prices({params => \%params})
305              
306             Returns a hash of tnt products for that request or undef in case of error.
307             $tnt->errors returns an array ref with error messages.
308              
309             =head2 hash_to_price_request_xml(\%hash)
310              
311             Takes a hash and turns it into a XML::LibXML::Document for a price request.
312              
313             =head2 http_ping
314              
315             Check if tnt server is reachable.
316              
317             =head2 tnt_get_price_url
318              
319             Returns the URL of the TNT price check interface.
320              
321             =head1 AUTHOR
322              
323             Jozef Kutej, C<< <jkutej at cpan.org> >>;
324             Andrea Pavlovic, C<< <spinne at cpan.org> >>
325              
326             =head1 CONTRIBUTORS
327              
328             The following people have contributed to the meon::Web by committing their
329             code, sending patches, reporting bugs, asking questions, suggesting useful
330             advice, nitpicking, chatting on IRC or commenting on my blog (in no particular
331             order):
332              
333             you?
334              
335             =head1 LICENSE AND COPYRIGHT
336              
337             This program is free software; you can redistribute it and/or modify it
338             under the terms of either: the GNU General Public License as published
339             by the Free Software Foundation; or the Artistic License.
340              
341             See http://dev.perl.org/licenses/ for more information.
342              
343             =cut