3.00_02!

diff --git a/Changes b/Changes
index 635b2b4..2556100 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,8 @@
 Revision history for Perl extension Business::OnlinePayment.
 
+3.00_02  Mon Jan 10 21:36:53 PST 2005
+       - HTTPS base class now has https_post in addition to https_get
+
 3.00_01  Thu Aug 26 04:49:26 2004
        - first of the v3 dev releases
 

diff --git a/OnlinePayment.pm b/OnlinePayment.pm
index c34ad8f..73e4010 100644 (file)
--- a/OnlinePayment.pm
+++ b/OnlinePayment.pm
@@ -11,7 +11,7 @@ require 5.004;
 #@EXPORT = qw();
 #@EXPORT_OK = qw();
 
-$VERSION = '3.00_01';
+$VERSION = '3.00_02';
 sub VERSION { #Argument "3.00_01" isn't numeric in subroutine entry
   local($^W)=0;
   UNIVERSAL::VERSION(@_);

diff --git a/OnlinePayment/HTTPS.pm b/OnlinePayment/HTTPS.pm
index 0ba897d..26f1748 100644 (file)
--- a/OnlinePayment/HTTPS.pm
+++ b/OnlinePayment/HTTPS.pm
@@ -1,7 +1,7 @@
 package Business::OnlinePayment::HTTPS;
 
 use strict;
-use vars qw($VERSION @ISA $ssl_module $skip_NetSSLeay);
+use vars qw($VERSION @ISA $DEBUG $ssl_module $skip_NetSSLeay);
 #use URI;
 #use URI::QueryParam;
 use URI::Escape;
@@ -9,7 +9,9 @@ use Tie::IxHash;
 
 @ISA = qw( Business::OnlinePayment );
 
-$VERSION = '0.01';
+$VERSION = '0.02';
+
+$DEBUG = 0;
 
 BEGIN {
 
@@ -34,7 +36,7 @@ BEGIN {
         }
 
         unless ( $ssl_module ) {
-                die "Net::SSLeay (+URI) or Crypt::SSLeay (+LWP) is required";
+                die "Net::SSLeay or Crypt::SSLeay (+LWP) is required";
         }
 
 }
@@ -128,10 +130,13 @@ sub https_get {
 
     import HTTP::Request::Common qw(GET);
 
+    my $url = 'https://'. $self->server;
+    $url .= ':'. $self->port
+      unless $self->port == 443;
+    $url .= '/'. $self->path;
+
     my $ua = new LWP::UserAgent;
-    my $res = $ua->request(
-      GET( 'https://'. $self->server. ':'. $self->port. '/'. $path )
-    );
+    my $res = $ua->request( GET( $url ) );
 
     #( $res->as_string, # wtf?
     ( $res->content,
@@ -147,16 +152,136 @@ sub https_get {
 
 }
 
-=item https_post
+=item https_post HASHREF | FIELD => VALUE, ...
 
-Not yet implemented
+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.
 
 =cut
 
 sub https_post {
   my $self = shift;
 
-  die "not yet implemented";
+  #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 $referer = ''; ### XXX referer!!!
+  my %headers;
+  $headers{'Referer'} = $referer if length($referer);
+  $headers{'Host'} = $self->server;
+
+  if ( $DEBUG ) {
+    warn join('', map { "  $_ => ". $post_data->{$_}. "\n" } keys %$post_data );
+  }
+
+  if ( $ssl_module eq 'Net::SSLeay' ) {
+
+    #import Net::SSLeay qw(post_https make_headers make_form);
+    import Net::SSLeay qw(make_headers make_form);
+    my $headers = make_headers(%headers);
+
+    if ( $DEBUG ) {
+      warn $self->server. ':'. $self->port. $self->path. "\n";
+      $Net::SSLeay::trace = 2;
+    }
+    #post_https( $self->server, $self->port, $self->path,
+    #            $headers, make_form(%$post_data)  );
+    _my_post_https( $self->server, $self->port, $self->path,
+                    $headers, make_form(%$post_data)  );
+
+  } elsif ( $ssl_module eq 'Crypt::SSLeay' ) {
+
+    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;
+    }
+
+    my $ua = new LWP::UserAgent;
+    my $res = $ua->request( POST( $url, [ %$post_data ] ) );
+
+    #( $res->as_string, # wtf?
+    ( $res->content,
+      $res->code,
+      map { $_ => $res->header($_) } $res->header_field_names
+    );
+
+  } else {
+
+    die "unknown SSL module $ssl_module";
+
+  }
+
+}
+
+# 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)
+               )
+           );
+}
+
+sub _my_do_httpx3 {
+    my ($method, $usessl, $site, $port, $path, $headers,
+       $content, $mime_type, $crt_path, $key_path) = @_;
+    my ($response, $page, $h,$v);
+
+    my $CRLF = $Net::SSLeay::CRLF;
+
+    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";
+    }
+
+    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