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

diff --git a/OnlinePayment/HTTPS.pm b/OnlinePayment/HTTPS.pm
index 0ba897d..1f84069 100644
--- a/OnlinePayment/HTTPS.pm
+++ b/OnlinePayment/HTTPS.pm
@@ -1,41 +1,43 @@
 package Business::OnlinePayment::HTTPS;
 
 use strict;
-use vars qw($VERSION @ISA $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.01';
+$VERSION = '0.07';
+$DEBUG   = 0;
 
 BEGIN {
 
-        $ssl_module = '';
+    $ssl_module = '';
+
+    eval {
+        die if defined($skip_NetSSLeay) && $skip_NetSSLeay;
+        require Net::SSLeay;
+        Net::SSLeay->VERSION(1.30);
+
+        #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 (+URI) or Crypt::SSLeay (+LWP) is required";
-        }
+    unless ($ssl_module) {
+        die "One of Net::SSLeay (v1.30 or later)"
+          . " or Crypt::SSLeay (+LWP) is required";
+    }
 
 }
 
@@ -45,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 ).
 
@@ -76,96 +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";
+    }
+
+    $opts->{"Content-Type"} ||= "application/x-www-form-urlencoded";
+
+    ### 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 );
+    }
+
+    $self->build_subs(qw( response_page response_code response_headers ));
+
+    if ( $ssl_module eq 'Net::SSLeay' ) {
+
+        import Net::SSLeay qw(get_https make_headers);
+        my $headers = make_headers(%headers);
+
+        my( $res_page, $res_code, @res_headers ) =
+          get_https( $self->server,
+                     $self->port,
+                     $path,
+                     $headers,
+                     "",
+                     $opts->{"Content-Type"},
+                   );
+
+        $self->response_page( $res_page );
+        $self->response_code( $res_code );
+        $self->response_headers( { @res_headers } );
+
+        ( $res_page, $res_code, @res_headers );
+
+    } elsif ( $ssl_module eq 'Crypt::SSLeay' ) {
+
+        import HTTP::Request::Common qw(GET);
+
+        my $url = 'https://' . $self->server;
+        $url .= ':' . $self->port
+          unless $self->port == 443;
+        $url .= "/$path";
+
+        my $ua = new LWP::UserAgent;
+        foreach my $hdr ( keys %headers ) {
+            $ua->default_header( $hdr => $headers{$hdr} );
+        }
+        my $res = $ua->request( GET($url) );
+
+        my @res_headers = map { $_ => $res->header($_) }
+                              $res->header_field_names;
+
+        $self->response_page( $res->content );
+        $self->response_code( $res->code );
+        $self->response_headers( { @res_headers } );
 
-  my $path = $self->path;
-  if ( keys %$post_data ) {
+        ( $res->content, $res->code, @res_headers );
 
-    #my $u = URI->new("", "https");
-    #$u->query_param(%$post_data);
-    #$path .= '?'. $u->query;
+    } else {
+        die "unknown SSL module $ssl_module";
+    }
 
-    $path .= '?'. join('&',
-      map { uri_escape($_).'='. uri_escape($post_data->{$_}) }
-      keys %$post_data
-    );
-    #warn $path;
+}
+
+=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).
+
+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.
 
+The options hashref supports setting headers and Content-Type:
+
+  {
+      headers => { 'X-Header1' => 'value', ... },
+      Content-Type => 'text/namevalue',
   }
 
-  my $referer = ''; ### XXX referer!!!
-  my %headers;
-  $headers{'Referer'} = $referer if length($referer);
+=cut
 
-  if ( $ssl_module eq 'Net::SSLeay' ) {
+sub https_post {
+    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_post called with no params\n";
+    }
+
+    $opts->{"Content-Type"} ||= "application/x-www-form-urlencoded";
+
+    ### XXX referer!!!
+    my %headers;
+    if ( ref( $opts->{headers} ) eq "HASH" ) {
+        %headers = %{ $opts->{headers} };
+    }
+    $headers{'Host'} ||= $self->server;
+
+    if ( $DEBUG && ref($post_data) ) {
+        warn "post data:\n",
+          join( '',
+            map { "  $_ => " . $post_data->{$_} . "\n" } keys %$post_data );
+    }
+
+    $self->build_subs(qw( response_page response_code response_headers ));
+
+    if ( $ssl_module eq 'Net::SSLeay' ) {
+
+        import Net::SSLeay qw(post_https make_headers make_form);
+        my $headers = make_headers(%headers);
+
+        if ($DEBUG) {
+            no warnings 'uninitialized';
+            warn $self->server . ':' . $self->port . $self->path . "\n";
+            $Net::SSLeay::trace = $DEBUG;
+        }
 
-    import Net::SSLeay qw(get_https make_headers);
-    my $headers = make_headers(%headers);
-    get_https( $self->server, $self->port, $path, $referer, $headers );
+        my $raw_data = ref($post_data) ? make_form(%$post_data) : $post_data;
 
-  } elsif ( $ssl_module eq 'Crypt::SSLeay' ) {
+        my( $res_page, $res_code, @res_headers ) =
+          post_https( $self->server,
+                      $self->port,
+                      $self->path,
+                      $headers,
+                      $raw_data,
+                      $opts->{"Content-Type"},
+                    );
 
-    import HTTP::Request::Common qw(GET);
+        $self->response_page( $res_page );
+        $self->response_code( $res_code );
+        $self->response_headers( { @res_headers } );
 
-    my $ua = new LWP::UserAgent;
-    my $res = $ua->request(
-      GET( 'https://'. $self->server. ':'. $self->port. '/'. $path )
-    );
+        ( $res_page, $res_code, @res_headers );
 
-    #( $res->as_string, # wtf?
-    ( $res->content,
-      $res->code,
-      map { $_ => $res->header($_) } $res->header_field_names
-    );
+    } elsif ( $ssl_module eq 'Crypt::SSLeay' ) {
 
-  } else {
+        import HTTP::Request::Common qw(POST);
 
-    die "unknown SSL module $ssl_module";
+        my $url = 'https://' . $self->server;
+        $url .= ':' . $self->port
+          unless $self->port == 443;
+        $url .= $self->path;
 
-  }
+        if ($DEBUG) {
+            warn $url;
+        }
 
-}
+        my $ua = new LWP::UserAgent;
+        foreach my $hdr ( keys %headers ) {
+            $ua->default_header( $hdr => $headers{$hdr} );
+        }
 
-=item https_post
+        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);
+        }
 
-Not yet implemented
+        my @res_headers = map { $_ => $res->header($_) }
+                              $res->header_field_names;
 
-=cut
+        $self->response_page( $res->content );
+        $self->response_code( $res->code );
+        $self->response_headers( { @res_headers } );
 
-sub https_post {
-  my $self = shift;
+        ( $res->content, $res->code, @res_headers );
+
+    } else {
+        die "unknown SSL module $ssl_module";
+    }
 
-  die "not yet implemented";
 }
 
 =back
 
-=head1 SEE ALSO 
+=head1 SEE ALSO
 
 L<Business::OnlinePayment>
 
 =cut
 
 1;
-