File Coverage

blib/lib/PayflowPro.pm
Criterion Covered Total %
statement 27 63 42.8
branch 2 14 14.2
condition 0 5 0.0
subroutine 9 10 90.0
pod 3 3 100.0
total 41 95 43.1


line stmt bran cond sub pod time code
1             # $Id: PayflowPro.pm 4712 2016-01-21 15:21:14Z khera $
2             #
3             # Copyright 2016 MailerMailer, LLC
4             #
5             # Based on documentation found at:
6             # http://www.pdncommunity.com/pdn/board/message?message.uid=28775
7             # http://www.pdncommunity.com/pdn/board/message?board.id=payflow&thread.id=1123
8              
9             package PayflowPro;
10 1     1   321362 use strict;
  1         3  
  1         44  
11              
12             =pod
13              
14             =head1 NAME
15              
16             PayflowPro - Library for accessing PayPal's Payflow Pro HTTP interface
17              
18             =head1 SYNOPSIS
19              
20             use PayflowPro qw(pfpro);
21             my $data = {
22             USER=>'MyUserId',
23             VENDOR=>'MyVendorId',
24             PARTNER=>'MyPartnerId',
25             PWD=>'MyPassword',
26              
27             AMT=> '42.24',
28             TAXAMT=>'0.00', # no tax charged, but specifying it lowers cost
29             INVNUM=>$$,
30             DESC=>"Test invoice $$",
31             COMMENT1=>"Comment 1 $$",
32             COMMENT2=>"Comment 2 $$",
33             CUSTCODE=>$$ . 'a' . $$,
34              
35             TRXTYPE=>'S', # sale
36             TENDER=>'C', # credit card
37              
38             # Commercial Card additional info
39             PONUM=>$$.'-'.$$,
40             SHIPTOZIP=>'20850', # for AmEx Level 2
41             DESC4=>'FRT0.00', # for AmEx Level 2
42              
43             # verisign tracking info
44             STREET => '123 AnyStreet',
45             CITY => 'Anytown',
46             COUNTRY => 'us',
47             FIRSTNAME => 'Firsty',
48             LASTNAME => 'Lasty',
49             STATE => 'md',
50             ZIP => '20850',
51              
52             ACCT => '5555555555554444',
53             EXPDATE => '1009',
54             CVV2 => '123',
55             };
56              
57             my $res = pfpro($data);
58              
59             if ($res->{RESULT} == 0) {
60             print "Woohooo! We charged the card!\n";
61             }
62              
63             =head1 DESCRIPTION
64              
65             Interface to HTTP gateway for PayPal's Payflow Pro service. Implements
66             the pfpro() function to simplify replacing the old PFProAPI perl module.
67              
68             Methods implemented are:
69              
70             =cut
71              
72 1     1   6 use base qw(Exporter);
  1         1  
  1         121  
73             @PayflowPro::EXPORT_OK = qw(pfpro pftestmode pfdebug);
74              
75 1     1   7120 use LWP::UserAgent;
  1         90545  
  1         35  
76 1     1   9 use HTTP::Request;
  1         2  
  1         26  
77 1     1   5 use Config;
  1         1  
  1         45  
78              
79 1     1   5 use constant NUMRETRIES => 3; # number of times to retry HTTP timeout/err
  1         2  
  1         79  
80 1     1   5 use vars qw($VERSION);
  1         2  
  1         967  
81              
82             $VERSION = sprintf "%d", q$Revision: 4712 $ =~ /(\d+)/;
83             my $agent = "MailerMailer PFPro";
84              
85             my ($pfprohost,$debug);
86             pftestmode(0); # set "live" mode as default.
87              
88             our $timeout = 30;
89              
90             my $ua = new LWP::UserAgent;
91             $ua->agent("$agent/$VERSION");
92              
93             =pod
94              
95             =head2 pftestmode($testmode)
96              
97             Set test mode on or off. Test mode means it uses the testing server
98             rather than the live one. Default mode is live (C<$testmode> == 0).
99              
100             Returns true.
101              
102             =cut
103              
104             sub pftestmode {
105 2     2 1 10 my $testmode = shift;
106              
107 2 100       8 $pfprohost = $testmode ?
108             'pilot-payflowpro.paypal.com' :
109             'payflowpro.paypal.com';
110              
111 2         4 return 1;
112             }
113              
114             =pod
115              
116             =head2 pfdebug($mode)
117              
118             Set debug mode on or off. Turns on some warn statements to track progress
119             of the request. Default mode is off (C<$mode> == 0).
120              
121             Returns current setting.
122              
123             =cut
124              
125             sub pfdebug {
126 1     1 1 5 my $mode = shift;
127              
128 1         10 $ENV{'HTTPS_DEBUG'} = $mode; # assumes Crypt::SSLeay as the SSL engine
129 1         2 return $debug = $mode;
130             }
131              
132             =pod
133              
134             =head2 pfpro($data)
135              
136             Process request as per hash ref C<$data>. See PFPro API docs on
137             name/value pairs to pass in. All we do here is convert them into an
138             HTTP request, then convert the response back into a hash and return
139             the reference to it. This emulates the pfpro() function in the
140             original API.
141              
142             Additionally, we honor a C value which specifies the number
143             of seconds to wait for a response from the server. The default is 30
144             seconds. Normally for production you should not need to alter this
145             value. The test servers are slower so may need larger timeout. The
146             minimum value that PayPal will accept is 5 seconds.
147              
148             It uses the time and the C (Invoice Number) field of input to
149             generate the unique request ID, so don't try to process the same
150             INVNUM more than once per second. C is a required datum to be
151             passed into this function. Bad things happen if you don't.
152              
153             Upon communications failure, it fakes up a response message with
154             C = -1. Internally, the library tries several times to process
155             the transaction if there are network problems before returning this
156             failure mode.
157              
158             To validate the SSL certificate, you need a ca-bundle file with a list
159             of valid certificate signers. Then set the environment variable
160             HTTPS_CA_FILE to point to that file. This assumes you are using the
161             C SSL driver for LWP (should be the default). In your code,
162             add some lines like this:
163              
164             # CA cert peer verification
165             $ENV{HTTPS_CA_FILE} = '/path/to/ca-bundle.crt';
166              
167             It is likely to be in F or F or
168             F depending on your OS version. The script
169             F included with this module can be used to create the
170             bundle file based on the current Mozilla certificate data if you don't
171             already have such a file. One is also included in the source for this
172             module, but it may be out of date so it is recommended that you run
173             the F script to ensure you have the latest
174             information. This program is copied from the CURL project
175             C
176              
177             If you do not set HTTPS_CA_FILE it will still work, but you don't get
178             the certificate validation to ensure you're speaking to the authentic
179             site. You will also get in the HTTPS response headers
180              
181             Client-SSL-Warning: Peer certificate not verified
182              
183             but you'll only see that if you turn on debugging.
184              
185             =cut
186              
187             sub pfpro {
188 0     0 1   my $data = shift;
189              
190             # for the case of a referenced credit, the INVNUM is not required to be set
191             # so use the ORIGID instead. If that's not set, just use a fixed string
192             # to avoid undef warnings.
193 0   0       my $request_id=substr(time . $data->{TRXTYPE} . ($data->{INVNUM} || $data->{ORIGID} || 'NOID'),0,32);
194 0           utf8::encode($request_id);
195              
196 0 0         if (defined $data->{TIMEOUT}) {
197 0           $timeout = $data->{TIMEOUT} + 0;
198             }
199              
200 0           $ua->timeout($timeout + 1); # one more than timeout in VPS header below
201              
202 0           my $r = HTTP::Request->new(POST => "https://$pfprohost/");
203 0           $r->content_type('text/namevalue');
204             $r->header('X-VPS-REQUEST-ID' => $request_id,
205             'X-VPS-CLIENT-TIMEOUT' => $timeout, # timeout in seconds
206             'X-VPS-VIT-INTEGRATION-PRODUCT' => $agent,
207             'X-VPS-VIT-INTEGRATION-VERSION' => $VERSION,
208             'X-VPS-VIT-OS-NAME' => $Config::Config{osname},
209             'X-VPS-VIT-OS-VERSION' => $Config::Config{osvers},
210 0           'X-VPS-VIT-RUNTIME-VERSION' => $],
211             'Connection' => 'close',
212             'Host' => $pfprohost,
213             );
214              
215             # build the body of the request
216 0           while (my ($k,$v) = each %{$data}) {
  0            
217 0           utf8::encode($v);
218 0           my $len = length($v);
219 0           $r->add_content($k."[$len]=".$v.'&');
220             }
221 0           $r->add_content('VERBOSITY=MEDIUM'); # from example code. unsure what it does
222              
223 0           $r->content_length(length(${$r->content_ref}));
  0            
224              
225 0 0         warn "HTTP Request:\n\n",$r->as_string() if $debug;
226              
227 0           my $retval = {}; # hash of values to return
228              
229 0           my $maxtries = NUMRETRIES;
230 0           my $response;
231              
232             # Keep trying the request until we succeed, or fail NUMRETRIES times.
233             # Since the REQUEST_ID is the same, we don't ever process
234             # the request more than once, but we deal with timout cases:
235             # If the request worked and we failed to get the response, we just
236             # get the original response back; if it failed to reach PayPal, we
237             # just retry it. NOTE: This does not retry on payflow errors, just
238             # when the HTTP protocol has failures/errors such as timeout.
239 0   0       do {
240 0 0         warn "Running request, $maxtries left\n" if $debug;
241 0           sleep ((NUMRETRIES - $maxtries) * 30); # delay for a bit between failures
242 0           $response = $ua->request($r);
243             } while (--$maxtries and not $response->is_success);
244              
245             # Check the outcome of the response
246 0 0         if ($response->is_success) {
247             # parse the return value into the hash and send it back.
248 0 0         warn "\nHTTP response:\n\n",$response->as_string if $debug;
249 0           my $c = $response->content;
250 0           foreach my $part (split '&',$c) {
251 0           my ($k,$v) = split '=',$part;
252 0           $retval->{$k} = $v;
253             }
254             } else {
255             # some error. fake up the old API's error code so existing code continues
256             # to work. this should just cause a retry on the application.
257 0 0         warn "HTTP communication error: ".$response->status_line()."\n" if $debug;
258 0           $retval->{RESULT} = -1;
259 0           $retval->{RESPMSG} = 'Failed to connect to host';
260             }
261              
262 0           $retval->{'X-VPS-REQUEST-ID'} = $request_id; # useful for debugging
263              
264 0           return $retval;
265             }
266              
267             1;
268              
269              
270             =pod
271              
272             =head1 AUTHOR
273              
274             Vivek Khera
275              
276             =head1 LICENSE
277              
278             This module is Copyright 2007-2016 Khera Communications, Inc. It is
279             licensed under the same terms as Perl itself.
280              
281             =cut