X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=OnlinePayment%2FHTTPS.pm;h=1f840697ec7d03350fe56bddfa3f0ab799d3d17b;hb=442ce3915cfcdb6586dddab405711004e82d663c;hp=cacd2c1b418fa8327bf49cdbee2cbc2c32cfece7;hpb=6c35ba5f7befdebd9e58f20bf65363a749997994;p=Business-OnlinePayment.git

diff --git a/OnlinePayment/HTTPS.pm b/OnlinePayment/HTTPS.pm
index cacd2c1..1f84069 100644
--- a/OnlinePayment/HTTPS.pm
+++ b/OnlinePayment/HTTPS.pm
@@ -1,43 +1,43 @@
 package Business::OnlinePayment::HTTPS;
 
 use strict;
-use vars qw($VERSION @ISA $DEBUG $ssl_module $skip_NetSSLeay);
-#use URI;
-#use URI::QueryParam;
+use vars qw($VERSION $DEBUG $ssl_module $skip_NetSSLeay);
 use URI::Escape;
 use Tie::IxHash;
+use base qw(Business::OnlinePayment);
 
-@ISA = qw( Business::OnlinePayment );
+$VERSION = '0.07';
+$DEBUG   = 0;
 
-$VERSION = '0.03';
+BEGIN {
 
-$DEBUG = 0;
+    $ssl_module = '';
 
-BEGIN {
+    eval {
+        die if defined($skip_NetSSLeay) && $skip_NetSSLeay;
+        require Net::SSLeay;
+        Net::SSLeay->VERSION(1.30);
 
-        $ssl_module = '';
+        #import Net::SSLeay
+        #  qw(get_https post_https make_form make_headers);
+        $ssl_module = 'Net::SSLeay';
+    };
 
+    if ($@) {
         eval {
-                die if defined($skip_NetSSLeay) && $skip_NetSSLeay;
-                require Net::SSLeay;
-                #import Net::SSLeay
-                #  qw(get_https post_https make_form make_headers);
-                $ssl_module = 'Net::SSLeay';
-        };
+            require LWP::UserAgent;
+            require HTTP::Request::Common;
+            require Crypt::SSLeay;
 
-        if ($@) {
-                eval {
-                        require LWP::UserAgent;
-                        require HTTP::Request::Common;
-                        require Crypt::SSLeay;
-                        #import HTTP::Request::Common qw(GET POST);
-                        $ssl_module = 'Crypt::SSLeay';
-                };
-        }
+            #import HTTP::Request::Common qw(GET POST);
+            $ssl_module = 'Crypt::SSLeay';
+        };
+    }
 
-        unless ( $ssl_module ) {
-                die "Net::SSLeay or Crypt::SSLeay (+LWP) is required";
-        }
+    unless ($ssl_module) {
+        die "One of Net::SSLeay (v1.30 or later)"
+          . " or Crypt::SSLeay (+LWP) is required";
+    }
 
 }
 
@@ -47,30 +47,30 @@ Business::OnlinePayment::HTTPS - Base class for HTTPS payment APIs
 
 =head1 SYNOPSIS
 
-  package Business::OnlinePayment::MyProcessor
-  @ISA = qw( Business::OnlinePayment::HTTPS );
-
+  package Business::OnlinePayment::MyProcessor;
+  use base qw(Business::OnlinePayment::HTTPS);
+  
   sub submit {
-          my $self = shift;
-
-          #...
-
-          # pass a list (order is preserved, if your gateway needs that)
-          ($page, $response, %reply_headers)
-            = $self->https_get( field => 'value', ... );
-
-          #or a hashref
-          my %hash = ( field => 'value', ... );
-          ($page, $response_code, %reply_headers)
-            = $self->https_get( $hashref );
-
-          #...
+      my $self = shift;
+  
+      #...
+  
+      # pass a list (order is preserved, if your gateway needs that)
+      ( $page, $response, %reply_headers )
+          = $self->https_get( field => 'value', ... );
+  
+      # or a hashref
+      my %hash = ( field => 'value', ... );
+      ( $page, $response_code, %reply_headers )
+            = $self->https_get( \%hash );
+  
+      #...
   }
 
 =head1 DESCRIPTION
 
-This is a base class for HTTPS based gateways, providing useful code for
-implementors of HTTPS payment APIs.
+This is a base class for HTTPS based gateways, providing useful code
+for implementors of HTTPS payment APIs.
 
 It depends on Net::SSLeay _or_ ( Crypt::SSLeay and LWP::UserAgent ).
 
@@ -78,236 +78,260 @@ It depends on Net::SSLeay _or_ ( Crypt::SSLeay and LWP::UserAgent ).
 
 =over 4
 
-=item https_get HASHREF | FIELD => VALUE, ...
+=item https_get [ \%options ] HASHREF | FIELD => VALUE, ...
+
+Accepts parameters as either a hashref or a list of fields and values.
+In the latter case, ordering is preserved (see L<Tie::IxHash> to do so
+when passing a hashref).
 
-Accepts parameters as either a hashref or a list of fields and values.  In the
-latter case, ordering is preserved (see L<Tie::IxHash> to do so when passing a
-hashref).
+Returns a list consisting of the page content as a string, the HTTP
+response code, and a list of key/value pairs representing the HTTP
+response headers.
 
-Returns a list consisting of the page content as a string, the HTTP response
-code, and a list of key/value pairs representing the HTTP response headers.
+The options hashref supports setting headers and Content-Type:
+
+  {
+      headers => { 'X-Header1' => 'value', ... },
+      Content-Type => 'text/namevalue',
+  }
 
 =cut
 
 sub https_get {
-  my $self = shift;
-
-  #accept a hashref or a list (keep it ordered)
-  my $post_data;
-  if ( ref($_[0]) ) {
-    $post_data = shift;
-  } else {
-    tie my %hash, 'Tie::IxHash', @_;
-    $post_data = \%hash;
-  }
+    my $self = shift;
+
+    # handle optional options hashref
+    my $opts;
+    if ( scalar(@_) > 1 and ref( $_[0] ) eq "HASH" ) {
+        $opts = shift;
+    }
+
+    # accept a hashref or a list (keep it ordered)
+    my $post_data;
+    if ( ref( $_[0] ) eq 'HASH' ) {
+        $post_data = shift;
+    }
+    elsif ( scalar(@_) > 1 ) {
+        tie my %hash, 'Tie::IxHash', @_;
+        $post_data = \%hash;
+    }
+    elsif ( scalar(@_) == 1 ) {
+        $post_data = shift;
+    }
+    else {
+        die "https_get called with no params\n";
+    }
 
-  my $path = $self->path;
-  if ( keys %$post_data ) {
+    $opts->{"Content-Type"} ||= "application/x-www-form-urlencoded";
 
-    #my $u = URI->new("", "https");
-    #$u->query_param(%$post_data);
-    #$path .= '?'. $u->query;
+    ### XXX referer!!!
+    my %headers;
+    if ( ref( $opts->{headers} ) eq "HASH" ) {
+        %headers = %{ $opts->{headers} };
+    }
+    $headers{'Host'} ||= $self->server;
+
+    my $path = $self->path;
+    if ( keys %$post_data ) {
+        $path .= '?'
+          . join( '&',
+            map { uri_escape($_) . '=' . uri_escape( $post_data->{$_} ) }
+              keys %$post_data );
+    }
 
-    $path .= '?'. join('&',
-      map { uri_escape($_).'='. uri_escape($post_data->{$_}) }
-      keys %$post_data
-    );
-    #warn $path;
+    $self->build_subs(qw( response_page response_code response_headers ));
 
-  }
+    if ( $ssl_module eq 'Net::SSLeay' ) {
 
-  my $referer = ''; ### XXX referer!!!
-  my %headers;
-  $headers{'Referer'} = $referer if length($referer);
+        import Net::SSLeay qw(get_https make_headers);
+        my $headers = make_headers(%headers);
 
-  if ( $ssl_module eq 'Net::SSLeay' ) {
+        my( $res_page, $res_code, @res_headers ) =
+          get_https( $self->server,
+                     $self->port,
+                     $path,
+                     $headers,
+                     "",
+                     $opts->{"Content-Type"},
+                   );
 
-    import Net::SSLeay qw(get_https make_headers);
-    my $headers = make_headers(%headers);
-    get_https( $self->server, $self->port, $path, $referer, $headers );
+        $self->response_page( $res_page );
+        $self->response_code( $res_code );
+        $self->response_headers( { @res_headers } );
 
-  } elsif ( $ssl_module eq 'Crypt::SSLeay' ) {
+        ( $res_page, $res_code, @res_headers );
 
-    import HTTP::Request::Common qw(GET);
+    } elsif ( $ssl_module eq 'Crypt::SSLeay' ) {
 
-    my $url = 'https://'. $self->server;
-    $url .= ':'. $self->port
-      unless $self->port == 443;
-    $url .= "/$path";
+        import HTTP::Request::Common qw(GET);
 
-    my $ua = new LWP::UserAgent;
-    my $res = $ua->request( GET( $url ) );
+        my $url = 'https://' . $self->server;
+        $url .= ':' . $self->port
+          unless $self->port == 443;
+        $url .= "/$path";
 
-    #( $res->as_string, # wtf?
-    ( $res->content,
-      $res->code,
-      map { $_ => $res->header($_) } $res->header_field_names
-    );
+        my $ua = new LWP::UserAgent;
+        foreach my $hdr ( keys %headers ) {
+            $ua->default_header( $hdr => $headers{$hdr} );
+        }
+        my $res = $ua->request( GET($url) );
 
-  } else {
+        my @res_headers = map { $_ => $res->header($_) }
+                              $res->header_field_names;
 
-    die "unknown SSL module $ssl_module";
+        $self->response_page( $res->content );
+        $self->response_code( $res->code );
+        $self->response_headers( { @res_headers } );
 
-  }
+        ( $res->content, $res->code, @res_headers );
+
+    } else {
+        die "unknown SSL module $ssl_module";
+    }
 
 }
 
-=item https_post SCALAR | HASHREF | FIELD => VALUE, ...
+=item https_post [ \%options ] SCALAR | HASHREF | FIELD => VALUE, ...
 
-Accepts form fields and values as either a hashref or a list.  In the latter
-case, ordering is preserved (see L<Tie::IxHash> to do so when passing a
-hashref).
+Accepts form fields and values as either a hashref or a list.  In the
+latter case, ordering is preserved (see L<Tie::IxHash> to do so when
+passing a hashref).
 
 Also accepts instead a simple scalar containing the raw content.
 
-Returns a list consisting of the page content as a string, the HTTP response
-code, and a list of key/value pairs representing the HTTP response headers.
+Returns a list consisting of the page content as a string, the HTTP
+response code, and a list of key/value pairs representing the HTTP
+response headers.
+
+The options hashref supports setting headers and Content-Type:
+
+  {
+      headers => { 'X-Header1' => 'value', ... },
+      Content-Type => 'text/namevalue',
+  }
 
 =cut
 
 sub https_post {
-  my $self = shift;
-
-  #accept a hashref or a list (keep it ordered)
-  my $post_data;
-  if ( ref($_[0]) eq 'HASH' ) {
-    $post_data = shift;
-  } elsif ( scalar(@_) > 1 ) {
-    tie my %hash, 'Tie::IxHash', @_;
-    $post_data = \%hash;
-  } elsif ( scalar(@_) == 1 ) {
-    $post_data = shift;
-  } else {
-    die "https_post called with no params\n";
-  }
+    my $self = shift;
 
-  my $referer = ''; ### XXX referer!!!
-  my %headers;
-  $headers{'Referer'} = $referer if length($referer);
-  $headers{'Host'} = $self->server;
+    # handle optional options hashref
+    my $opts;
+    if ( scalar(@_) > 1 and ref( $_[0] ) eq "HASH" ) {
+        $opts = shift;
+    }
 
-  if ( $DEBUG && ref($post_data) ) {
-    warn join('', map { "  $_ => ". $post_data->{$_}. "\n" } keys %$post_data );
-  }
+    # accept a hashref or a list (keep it ordered)
+    my $post_data;
+    if ( ref( $_[0] ) eq 'HASH' ) {
+        $post_data = shift;
+    }
+    elsif ( scalar(@_) > 1 ) {
+        tie my %hash, 'Tie::IxHash', @_;
+        $post_data = \%hash;
+    }
+    elsif ( scalar(@_) == 1 ) {
+        $post_data = shift;
+    }
+    else {
+        die "https_post called with no params\n";
+    }
 
-  if ( $ssl_module eq 'Net::SSLeay' ) {
+    $opts->{"Content-Type"} ||= "application/x-www-form-urlencoded";
 
-    #import Net::SSLeay qw(post_https make_headers make_form);
-    import Net::SSLeay qw(make_headers make_form);
-    my $headers = make_headers(%headers);
+    ### XXX referer!!!
+    my %headers;
+    if ( ref( $opts->{headers} ) eq "HASH" ) {
+        %headers = %{ $opts->{headers} };
+    }
+    $headers{'Host'} ||= $self->server;
 
-    if ( $DEBUG ) {
-      warn $self->server. ':'. $self->port. $self->path. "\n";
-      $Net::SSLeay::trace = 2;
+    if ( $DEBUG && ref($post_data) ) {
+        warn "post data:\n",
+          join( '',
+            map { "  $_ => " . $post_data->{$_} . "\n" } keys %$post_data );
     }
-    #post_https( $self->server, $self->port, $self->path,
-    #            $headers, make_form(%$post_data)  );
 
-    my $raw_data = ref($post_data) ? make_form(%$post_data) : $post_data;
-    _my_post_https( $self->server, $self->port, $self->path,
-                    $headers, $raw_data );
+    $self->build_subs(qw( response_page response_code response_headers ));
 
-  } elsif ( $ssl_module eq 'Crypt::SSLeay' ) {
+    if ( $ssl_module eq 'Net::SSLeay' ) {
 
-    import HTTP::Request::Common qw(POST);
+        import Net::SSLeay qw(post_https make_headers make_form);
+        my $headers = make_headers(%headers);
 
-    my $url = 'https://'. $self->server;
-    $url .= ':'. $self->port
-      unless $self->port == 443;
-    $url .= $self->path;
+        if ($DEBUG) {
+            no warnings 'uninitialized';
+            warn $self->server . ':' . $self->port . $self->path . "\n";
+            $Net::SSLeay::trace = $DEBUG;
+        }
 
-    if ( $DEBUG ) {
-      warn $url;
-    }
+        my $raw_data = ref($post_data) ? make_form(%$post_data) : $post_data;
 
-    my $ua = new LWP::UserAgent;
+        my( $res_page, $res_code, @res_headers ) =
+          post_https( $self->server,
+                      $self->port,
+                      $self->path,
+                      $headers,
+                      $raw_data,
+                      $opts->{"Content-Type"},
+                    );
 
-    my $res;
-    if ( ref($post_data) ) {
-      $res = $ua->request( POST( $url, [ %$post_data ] ) );
-    } else {
-      my $req =new HTTP::Request( 'POST' => $url );
-      $req->content_type('application/x-www-form-urlencoded');
-      $req->content($post_data);
-      $res = $ua->request($req);
-    }
+        $self->response_page( $res_page );
+        $self->response_code( $res_code );
+        $self->response_headers( { @res_headers } );
 
-    #( $res->as_string, # wtf?
-    ( $res->content,
-      $res->code,
-      map { $_ => $res->header($_) } $res->header_field_names
-    );
+        ( $res_page, $res_code, @res_headers );
 
-  } else {
+    } elsif ( $ssl_module eq 'Crypt::SSLeay' ) {
 
-    die "unknown SSL module $ssl_module";
+        import HTTP::Request::Common qw(POST);
 
-  }
+        my $url = 'https://' . $self->server;
+        $url .= ':' . $self->port
+          unless $self->port == 443;
+        $url .= $self->path;
 
-}
+        if ($DEBUG) {
+            warn $url;
+        }
 
-# SecureHostingUPG (and presumably other IIS-based gateways?) doesn't like the
-# Host: $site:$port header auto-added by Net::SSLeay, which it adds regardless
-# if you supply one or not
-
-sub _my_post_https ($$$;***) { _my_do_httpx2(POST => 1, @_) }
-
-sub _my_do_httpx2 {
-    my ($page, $response, $headers, $server_cert) = &_my_do_httpx3;
-    Net::SSLeay::X509_free($server_cert) if defined $server_cert;
-    my($h,$v);
-    return ($page, $response,
-	    map( { ($h,$v)=/^(\S+)\:\s*(.*)$/; (uc($h),$v); }
-		split(/\s?\n/, $headers)
-		)
-	    );
-}
+        my $ua = new LWP::UserAgent;
+        foreach my $hdr ( keys %headers ) {
+            $ua->default_header( $hdr => $headers{$hdr} );
+        }
+
+        my $res;
+        if ( ref($post_data) ) {
+            $res = $ua->request( POST( $url, [%$post_data] ) );
+        }
+        else {
+            my $req = new HTTP::Request( 'POST' => $url );
+            $req->content_type( $opts->{"Content-Type"} );
+            $req->content($post_data);
+            $res = $ua->request($req);
+        }
 
-sub _my_do_httpx3 {
-    my ($method, $usessl, $site, $port, $path, $headers,
-	$content, $mime_type, $crt_path, $key_path) = @_;
-    my ($response, $page, $h,$v);
+        my @res_headers = map { $_ => $res->header($_) }
+                              $res->header_field_names;
 
-    my $CRLF = $Net::SSLeay::CRLF;
+        $self->response_page( $res->content );
+        $self->response_code( $res->code );
+        $self->response_headers( { @res_headers } );
+
+        ( $res->content, $res->code, @res_headers );
 
-    if ($content) {
-	$mime_type = "application/x-www-form-urlencoded" unless $mime_type;
-	my $len = Net::SSLeay::blength($content);
-	$content = "Content-Type: $mime_type$CRLF"
-	    . "Content-Length: $len$CRLF$CRLF$content";
     } else {
-	$content = "$CRLF$CRLF";
+        die "unknown SSL module $ssl_module";
     }
 
-    my $req = "$method $path HTTP/1.0$CRLF";
-    unless ( defined $headers && $headers =~ /^Host:/m ) {
-      $req .= "Host: $site";
-      unless ( ( $port==80 && !$usessl ) || ( $port==443 && $usessl ) ) {
-        $req .= ":$port";
-      }
-      $req .= $CRLF;
-    }
-    $req .= (defined $headers ? $headers : '') . "Accept: */*$CRLF$content";    
-
-    warn "do_httpx3($method,$usessl,$site:$port)" if $Net::SSLeay::trace;
-    my ($http, $errs, $server_cert)
-	= Net::SSLeay::httpx_cat($usessl, $site, $port, $req, $crt_path, $key_path);
-    return (undef, "HTTP/1.0 900 NET OR SSL ERROR$CRLF$CRLF$errs") if $errs;
-    
-    $http = '' if !defined $http;
-    ($headers, $page) = split /\s?\n\s?\n/, $http, 2;
-    warn "headers >$headers< page >>$page<< http >>>$http<<<" if $Net::SSLeay::trace>1;
-    ($response, $headers) = split /\s?\n/, $headers, 2;
-    return ($page, $response, $headers, $server_cert);
 }
 
 =back
 
-=head1 SEE ALSO 
+=head1 SEE ALSO
 
 L<Business::OnlinePayment>
 
 =cut
 
 1;
-