lib/Vend/Payment.pm

   1 # Vend::Payment - Interchange payment processing routines
   2 #
   3 # $Id: Payment.pm,v 2.23 2009-03-20 22:15:56 markj Exp $
   4 #
   5 # Copyright (C) 2002-2009 Interchange Development Group
   6 # Copyright (C) 1996-2002 Red Hat, Inc.
   7 #
   8 # This program is free software; you can redistribute it and/or modify
   9 # it under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation; either version 2 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # This program is distributed in the hope that it will be useful,
  14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 # GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public
  19 # License along with this program; if not, write to the Free
  20 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  21 # MA  02110-1301  USA.
  22
  23 package Vend::Payment;
  24 require Exporter;
  25
  26 $VERSION = substr(q$Revision: 2.23 $, 10);
  27
  28 @ISA = qw(Exporter);
  29
  30 @EXPORT = qw(
  31                                 charge
  32                                 charge_param
  33                 );
  34
  35 @EXPORT_OK = qw(
  36                                 map_actual
  37                 );
  38
  39 use Vend::Util;
  40 use Vend::Interpolate;
  41 use Vend::Order;
  42 use IO::Pipe;
  43 use strict;
  44
  45 use vars qw/$Have_LWP $Have_Net_SSLeay/;
  46
  47 my $pay_opt;
  48
  49 my %cyber_remap = (
  50         qw/
  51                 configfile CYBER_CONFIGFILE
  52         id         CYBERCASH_ID
  53         mode       CYBER_MODE
  54         host       CYBER_HOST
  55         port       CYBER_PORT
  56         remap      CYBER_REMAP
  57         currency   CYBER_CURRENCY
  58         precision  CYBER_PRECISION
  59         /
  60 );
  61
  62 my %ignore_mv_payment = (
  63         qw/
  64                 gateway 1
  65         /
  66 );
  67
  68 sub charge_param {
  69         my ($name, $value, $mode) = @_;
  70         my $opt;
  71
  72         if($mode) {
  73                 $opt = $Vend::Cfg->{Route_repository}{$mode} ||= {};
  74         }
  75         else {
  76                 $opt = $pay_opt ||= {};
  77         }
  78
  79         if($name =~ s/^mv_payment_//i) {
  80                 $name = lc $name;
  81         }
  82
  83         if(defined $value) {
  84                 return $pay_opt->{$name} = $value;
  85         }
  86
  87         # Find if set in route or options
  88         return $opt->{$name}            if defined $opt->{$name};
  89
  90         # "gateway" and possibly other future options
  91         return undef if $ignore_mv_payment{$name};
  92
  93         # Now check Variable space as last resort
  94         my $uname = "MV_PAYMENT_\U$name";
  95
  96         return $::Variable->{$uname} if defined $::Variable->{$uname};
  97         return $::Variable->{$cyber_remap{$name}}
  98                 if defined $::Variable->{$cyber_remap{$name}};
  99         return undef;
 100 }
 101
 102 # Do remapping of payment variables submitted by user
 103 # Can be changed/extended with remap/MV_PAYMENT_REMAP
 104 sub map_actual {
 105         my ($vref, $cref) = (@_);
 106         $vref = $::Values               unless $vref;
 107         $cref = \%CGI::values   unless $cref;
 108         my @map = qw(
 109
 110                 address
 111                 address1
 112                 address2
 113                 amount
 114                 b_address
 115                 b_address1
 116                 b_address2
 117                 b_city
 118                 b_country
 119                 b_company
 120                 b_fname
 121                 b_lname
 122                 b_name
 123                 b_state
 124                 b_zip
 125                 check_account
 126                 check_acctname
 127                 check_accttype
 128                 check_bankname
 129                 check_checktype
 130                 check_dl
 131                 check_magstripe
 132                 check_number
 133                 check_routing
 134                 check_transit
 135                 city
 136                 comment1
 137                 comment2
 138                 corpcard_type
 139                 country
 140                 cvv2
 141                 email
 142                 company
 143                 fname
 144                 item_code
 145                 item_desc
 146                 lname
 147                 mv_credit_card_cvv2
 148                 mv_credit_card_exp_month
 149                 mv_credit_card_exp_year
 150                 mv_credit_card_number
 151                 mv_order_number
 152                 mv_transaction_id
 153                 name
 154                 origin_zip
 155                 phone_day
 156                 phone_night
 157                 pin
 158                 po_number
 159                 salestax
 160                 shipping
 161                 state
 162                 tax_duty
 163                 tax_exempt
 164                 tender
 165                 zip
 166         );
 167
 168         my %map = qw(
 169                 cyber_mode               mv_cyber_mode
 170                 comment                  giftnote
 171         );
 172         @map{@map} = @map;
 173
 174         # Allow remapping of the variable names
 175         my $remap;
 176         if( $remap      = charge_param('remap') ) {
 177                 $remap =~ s/^\s+//;
 178                 $remap =~ s/\s+$//;
 179                 my (%remap) = split /[\s=]+/, $remap;
 180                 for (keys %remap) {
 181                         $map{$_} = $remap{$_};
 182                 }
 183         }
 184
 185         my %actual;
 186         my $key;
 187
 188         my %billing_set;
 189         my @billing_set = qw/
 190                                                         b_address1
 191                                                         b_address2
 192                                                         b_address3
 193                                                         b_city
 194                                                         b_state
 195                                                         b_zip
 196                                                         b_country
 197                                                 /;
 198
 199         my @billing_ind = qw/
 200                                                         b_address1
 201                                                         b_city
 202                                                 /;
 203
 204         if(my $str = $::Variable->{MV_PAYMENT_BILLING_SET}) {
 205                 @billing_set = grep $_ !~ /\W/, split /[\s,\0]+/, $str;
 206         }
 207         if(my $str = $::Variable->{MV_PAYMENT_BILLING_INDICATOR}) {
 208                 @billing_ind = grep $_ !~ /\W/, split /[\s,\0]+/, $str;
 209         }
 210
 211         @billing_set{@billing_set} = @billing_set;
 212
 213         my $no_billing_xfer = 1;
 214
 215         for(@billing_ind) {
 216                 $no_billing_xfer = 0  unless length($vref->{$_});
 217         }
 218
 219         # pick out the right values, need alternate billing address
 220         # substitution
 221         foreach $key (keys %map) {
 222                 $actual{$key} = $vref->{$map{$key}} || $cref->{$key};
 223                 my $secondary = $key;
 224                 next unless $secondary =~ s/^b_//;
 225                 if ($billing_set{$key}) {
 226                         next if $no_billing_xfer;
 227                         $actual{$key} = $vref->{$secondary};
 228                         next;
 229                 }
 230                 next if $actual{$key};
 231                 $actual{$key} = $vref->{$map{$secondary}} || $cref->{$map{$secondary}};
 232         }
 233
 234         $actual{name}            = "$actual{fname} $actual{lname}"
 235                 if $actual{lname};
 236         $actual{b_name}          = "$actual{b_fname} $actual{b_lname}"
 237                 if $actual{b_lname};
 238         if($actual{b_address1}) {
 239                 $actual{b_address} = "$actual{b_address1}";
 240                 $actual{b_address} .=  ", $actual{b_address2}"
 241                         if $actual{b_address2};
 242         }
 243         if($actual{address1}) {
 244                 $actual{address} = "$actual{address1}";
 245                 $actual{address} .=  ", $actual{address2}"
 246                         if $actual{address2};
 247         }
 248
 249         # Do some standard processing of credit card expirations
 250         $actual{mv_credit_card_exp_month} =~ s/\D//g;
 251         $actual{mv_credit_card_exp_month} =~ s/^0+//;
 252         $actual{mv_credit_card_exp_year} =~ s/\D//g;
 253         $actual{mv_credit_card_exp_year} =~ s/\d\d(\d\d)/$1/;
 254
 255         $actual{mv_credit_card_reference} = $actual{mv_credit_card_number} =~ s/\D//g;
 256         $actual{mv_credit_card_reference} =~ s/^(\d\d).*(\d\d\d\d)$/$1**$2/;
 257
 258     $actual{mv_credit_card_exp_all} = sprintf(
 259                                         '%02d/%02d',
 260                                         $actual{mv_credit_card_exp_month},
 261                                         $actual{mv_credit_card_exp_year},
 262                                       );
 263
 264         $actual{cyber_mode} = charge_param('transaction')
 265                                                 ||      $actual{cyber_mode}
 266                                                 || 'mauthcapture';
 267
 268         return %actual;
 269 }
 270
 271 sub gen_order_id {
 272         my $opt = shift || {};
 273         if( $opt->{order_id}) {
 274                 # do nothing, already set
 275         }
 276         elsif($opt->{counter}) {
 277                 $opt->{order_id} = Vend::Interpolate::tag_counter(
 278                                                 $opt->{counter},
 279                                                 { start => $opt->{counter_start} || 100000,
 280                                                   sql   => $opt->{sql_counter},
 281                                                 },
 282                                         );
 283         }
 284         else {
 285                 my(@t) = gmtime(time());
 286                 my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = @t;
 287                 $opt->{order_id} = POSIX::strftime("%y%m%d%H%M%S$$", @t);
 288
 289         }
 290
 291         return $opt->{order_id};
 292 }
 293
 294 sub charge {
 295         my ($charge_type, $opt) = @_;
 296
 297         my $pay_route;
 298
 299         ### We get the payment base information from a route with the
 300         ### same name as $charge_type if it is there
 301         if($Vend::Cfg->{Route}) {
 302                 $pay_route = $Vend::Cfg->{Route_repository}{$charge_type} || {};
 303         }
 304         else {
 305                 $pay_route = {};
 306         }
 307
 308         ### Then we take any payment options set in &charge, [charge ...],
 309         ### or $Tag->charge
 310
 311         # $pay_opt is package-scoped but lexical
 312         $pay_opt = { %$pay_route };
 313         for(keys %$opt) {
 314                 $pay_opt->{$_} = $opt->{$_};
 315         }
 316
 317         # We relocate these to subroutines to standardize
 318
 319         ### Maps the form variable names to the names needed by the routine
 320         ### Standard names are defined ala Interchange or MV4.0x, b_name, lname,
 321         ### etc. with b_varname taking precedence for these. Falls back to lname
 322         ### if the b_lname is not set
 323         my (%actual) = map_actual();
 324         $pay_opt->{actual} = \%actual;
 325
 326         # We relocate this to a subroutine to standardize. Uses the payment
 327         # counter if there
 328         my $orderID = gen_order_id($pay_opt);
 329
 330         ### Set up the amounts. The {amount} key will have the currency prepended,
 331         ### e.g. "usd 19.95". {total_cost} has just the cost.
 332
 333         # Uses the {currency} -> MV_PAYMENT_CURRENCY options if set
 334         my $currency =  charge_param('currency')
 335                                         || ($Vend::Cfg->{Locale} && $Vend::Cfg->{Locale}{currency_code})
 336                                         || 'usd';
 337
 338         # Uses the {precision} -> MV_PAYMENT_PRECISION options if set
 339         my $precision = charge_param('precision') || 2;
 340         my $penny     = charge_param('penny_pricing') || 0;
 341
 342         my $amount = $pay_opt->{amount} || Vend::Interpolate::total_cost();
 343         $amount = round_to_frac_digits($amount, $precision);
 344         $amount = sprintf "%.${precision}f", $amount;
 345         $amount *= 100 if $penny;
 346
 347         $pay_opt->{total_cost} = $amount;
 348         $pay_opt->{amount} = "$currency $amount";
 349
 350         ###
 351         ### Finish setting amounts and currency
 352
 353         # If we have a previous payment amount, delete it but push it on a stack
 354         #
 355         my $stack = $Vend::Session->{payment_stack} || [];
 356         delete $Vend::Session->{payment_result};
 357         delete $Vend::Session->{cybercash_result}; ### Deprecated
 358
 359 #::logDebug("Called charge at " . scalar(localtime));
 360 #::logDebug("Charge caller is " . join(':', caller));
 361
 362 #::logDebug("mode=$pay_opt->{gateway}");
 363 #::logDebug("pay_opt=" . ::uneval($pay_opt));
 364         # Default to the gateway same as charge type if no gateway specified,
 365         # and set the gateway in the session for logging on completion
 366         if(! $opt->{gateway}) {
 367                 $pay_opt->{gateway} = charge_param('gateway') || $charge_type;
 368         }
 369         #$charge_type ||= $pay_opt->{gateway};
 370         $Vend::Session->{payment_mode} = $pay_opt->{gateway};
 371
 372         # See if we are in test mode
 373         $pay_opt->{test} = charge_param('test');
 374
 375         # just convenience
 376         my $gw = $pay_opt->{gateway};
 377
 378         # See if we are calling a defined GlobalSub payment mode
 379         my $sub = $Global::GlobalSub->{$gw};
 380
 381         # Try our predefined modes
 382         if (! $sub and defined &{"Vend::Payment::$gw"} ) {
 383                 $sub = \&{"Vend::Payment::$gw"};
 384         }
 385
 386         # This is the return from all routines
 387         my %result;
 388
 389         if($sub) {
 390 #::logDebug("Charge sub");
 391                 # Calling a defined GlobalSub payment mode
 392                 # Arguments are the passed option hash (if any) and the route hash
 393
 394         my $pid;
 395         my $timeout = $pay_opt->{global_timeout} || charge_param('global_timeout');
 396
 397         %result = eval {
 398             if ($timeout > 0) {
 399
 400                 my $pipe = IO::Pipe->new;
 401
 402                 unless ($pid = fork) {
 403                     Vend::Server::child_process_dbi_prep();
 404                     $pipe->writer;
 405                     my %rv = $sub->($pay_opt);
 406                     $pipe->print( ::uneval(\%rv) );
 407                     exit;
 408                 }
 409
 410                 $pipe->reader;
 411
 412                 my $to_msg = $pay_opt->{global_timeout_msg}
 413                     || charge_param('global_timeout_msg')
 414                     || 'Due to technical difficulties, your order could not be processed.';
 415                 local $SIG{ALRM} = sub { die "$to_msg\n" };
 416
 417                 alarm $timeout;
 418                 wait;
 419                 alarm 0;
 420
 421                 $pid = undef;
 422
 423                 my $rv = eval join ('', $pipe->getlines);
 424
 425                 return %$rv;
 426             }
 427
 428             return $sub->($pay_opt);
 429         };
 430
 431                 if($@) {
 432                         my $msg = errmsg(
 433                                                 "payment routine '%s' returned error: %s",
 434                                                 $charge_type,
 435                                                 $@,
 436                         );
 437             kill (KILL => $pid)
 438                 if $pid && kill (0 => $pid);
 439                         ::logError($msg);
 440                         $result{MStatus} = 'died';
 441                         $result{MErrMsg} = $msg;
 442                 }
 443         }
 444         elsif($charge_type =~ /^\s*custom\s+(\w+)(?:\s+(.*))?/si) {
 445 #::logDebug("Charge custom");
 446                 # MV4 and IC4.6.x methods
 447                 my (@args);
 448                 @args = Text::ParseWords::shellwords($2) if $2;
 449                 if(! defined ($sub = $Global::GlobalSub->{$1}) ) {
 450                         ::logError("bad custom payment GlobalSub: %s", $1);
 451                         return undef;
 452                 }
 453                 eval {
 454                         %result = $sub->(@args);
 455                 };
 456                 if($@) {
 457                         my $msg = errmsg(
 458                                                 "payment routine '%s' returned error: %s",
 459                                                 $charge_type,
 460                                                 $@,
 461                         );
 462                         ::logError($msg);
 463                         $result{MStatus} = $msg;
 464                 }
 465         }
 466         elsif (
 467                         $actual{cyber_mode} =~ /^minivend_test(?:_(.*))?/
 468                                 or
 469                         $charge_type =~ /^internal_test(?:[ _]+(.*))?/
 470                   )
 471         {
 472 #::logDebug("Internal test");
 473
 474                 # Test mode....
 475
 476                 my $status = $1 || charge_param('result') || undef;
 477                 # Interchange test mode
 478                 my %payment = ( %$pay_opt );
 479                 &testSetServer ( %payment );
 480                 %result = testsendmserver(
 481                         $actual{cyber_mode},
 482                         'Order-ID'     => $orderID,
 483                         'Amount'       => $amount,
 484                         'Card-Number'  => $actual{mv_credit_card_number},
 485                         'Card-Name'    => $actual{b_name},
 486                         'Card-Address' => $actual{b_address},
 487                         'Card-City'    => $actual{b_city},
 488                         'Card-State'   => $actual{b_state},
 489                         'Card-Zip'     => $actual{b_zip},
 490                         'Card-Country' => $actual{b_country},
 491                         'Card-Exp'     => $actual{mv_credit_card_exp_all},
 492                 );
 493                 $result{MStatus} = $status if defined $status;
 494         }
 495         else {
 496 #::logDebug("Unknown charge type");
 497                 my $msg = errmsg("Unknown charge type: %s", $charge_type);
 498                 ::logError($msg);
 499                 $result{MStatus} = $msg;
 500         }
 501
 502         push @$stack, \%result;
 503         $Vend::Session->{payment_result} = \%result;
 504         $Vend::Session->{payment_stack}  = $stack;
 505
 506         my $svar = charge_param('success_variable') || 'MStatus';
 507         my $evar = charge_param('error_variable')   || 'MErrMsg';
 508
 509         if($result{$svar} !~ /^success/) {
 510                 $Vend::Session->{payment_error} = $result{$evar};
 511                 if ($result{$evar} =~ /\S/) {
 512                         $Vend::Session->{errors}{mv_credit_card_valid} = $result{$evar};
 513                 }
 514                 $result{'invalid-order-id'} = delete $result{'order-id'}
 515                         if $result{'order-id'};
 516         }
 517         elsif($result{$svar} =~ /success-duplicate/) {
 518                 $Vend::Session->{payment_error} = $result{$evar};
 519                 $result{'invalid-order-id'} = delete $result{'order-id'}
 520                         if $result{'order-id'};
 521         }
 522         else {
 523                 delete $Vend::Session->{payment_error};
 524         }
 525
 526         $Vend::Session->{payment_id} = $result{'order-id'};
 527
 528         my $encrypt = charge_param('encrypt');
 529
 530         if($encrypt and $CGI::values{mv_credit_card_number} and $Vend::Cfg->{EncryptKey}) {
 531                 my $prog = charge_param('encrypt_program') || $Vend::Cfg->{EncryptProgram};
 532                 if($prog =~ /pgp|gpg/) {
 533                         $CGI::values{mv_credit_card_force} = 1;
 534                         (
 535                                 undef,
 536                                 $::Values->{mv_credit_card_info},
 537                                 $::Values->{mv_credit_card_exp_month},
 538                                 $::Values->{mv_credit_card_exp_year},
 539                                 $::Values->{mv_credit_card_exp_all},
 540                                 $::Values->{mv_credit_card_type},
 541                                 $::Values->{mv_credit_card_error}
 542                         )       = encrypt_standard_cc(\%CGI::values);
 543                 }
 544         }
 545         ::logError(
 546                                 "Order id for charge type %s: %s",
 547                                 $charge_type,
 548                                 $Vend::Session->{cybercash_id},
 549                         )
 550                 if $pay_opt->{log_to_error};
 551
 552         # deprecated
 553         for(qw/ id error result /) {
 554                 $Vend::Session->{"cybercash_$_"} = $Vend::Session->{"payment_$_"};
 555         }
 556
 557         return \%result if $pay_opt->{hash};
 558         return $result{'order-id'};
 559 }
 560
 561 sub testSetServer {
 562         my %options = @_;
 563         my $out = '';
 564         for(sort keys %options) {
 565                 $out .= "$_=$options{$_}\n";
 566         }
 567         logError("Test CyberCash SetServer:\n%s\n" , $out);
 568         1;
 569 }
 570
 571 sub testsendmserver {
 572         my ($type, %options) = @_;
 573         my $out ="type=$type\n";
 574         for(sort keys %options) {
 575                 $out .= "$_=$options{$_}\n";
 576         }
 577         logError("Test CyberCash sendmserver:\n$out\n");
 578         my $oid;
 579         eval {
 580                 $oid = Vend::Interpolate::tag_counter(
 581                                         "$Vend::Cfg->{ScratchDir}/internal_test.payment.number"
 582                                         );
 583         };
 584         return ('MStatus', 'success', 'order-id', $oid || 'COUNTER_FAILED');
 585 }
 586
 587 sub post_data {
 588         my ($opt, $query) = @_;
 589
 590         unless ($opt->{use_wget} or $Have_Net_SSLeay or $Have_LWP) {
 591                 die "No Net::SSLeay or Crypt::SSLeay found.\n";
 592         }
 593
 594         my $submit_url = $opt->{submit_url};
 595         my $server;
 596         my $port = $opt->{port} || 443;
 597         my $script;
 598         my $protocol = $opt->{protocol} || 'https';
 599         if($submit_url) {
 600                 $server = $submit_url;
 601                 $server =~ s{^https://}{}i;
 602                 $server =~ s{(/.*)}{};
 603                 $port = $1 if $server =~ s/:(\d+)$//;
 604                 $script = $1;
 605         }
 606         elsif ($opt->{host}) {
 607                 $server = $opt->{host};
 608                 $script = $opt->{script};
 609                 $script =~ s:^([^/]):/$1:;
 610                 $submit_url = join "",
 611                                                 $protocol,
 612                                                 '://',
 613                                                 $server,
 614                                                 ($port ? ":$port" : ''),
 615                                                 $script,
 616                                                 ;
 617         }
 618         my %header = ( 'User-Agent' => "Vend::Payment (Interchange version $::VERSION)");
 619         if($opt->{extra_headers}) {
 620                 for(keys %{$opt->{extra_headers}}) {
 621                         $header{$_} = $opt->{extra_headers}{$_};
 622                 }
 623         }
 624
 625         my %result;
 626         if($opt->{use_wget}) {
 627                 ## Don't worry about OS independence with UNIX wget
 628                 my $bdir = "$Vend::Cfg->{ScratchDir}/wget";
 629
 630                 unless (-d $bdir) {
 631                         mkdir $bdir, 0777
 632                                 or do {
 633                                         my $msg = "Failed to create directory %s: %s";
 634                                         $msg = errmsg($msg, $bdir, $!);
 635                                         logError($msg);
 636                                         die $msg;
 637                                 };
 638                 }
 639
 640                 my $filebase = "$Vend::SessionID.wget";
 641                 my $statfile = Vend::File::get_filename("$filebase.stat", 1, 1, $bdir);
 642                 my $outfile  = Vend::File::get_filename("$filebase.out", 1, 1, $bdir);
 643                 my $infile   = Vend::File::get_filename("$filebase.in", 1, 1, $bdir);
 644                 my $cmd = $opt->{use_wget} =~ m{/} ? $opt->{use_wget} : 'wget';
 645
 646                 my @post;
 647                 while( my ($k,$v) = each %$query ) {
 648                         $k = hexify($k);
 649                         $v = hexify($v);
 650                         push @post, "$k=$v";
 651                 }
 652                 my $post = join "&", @post;
 653                 open WIN, "> $infile"
 654                         or die errmsg("Cannot create wget post input file %s: %s", $infile, $!) . "\n";
 655                 print WIN $post;
 656                 local($/);
 657
 658                 my @args = $cmd;
 659                 push @args, "--output-file=$statfile";
 660                 push @args, "--output-document=$outfile";
 661                 push @args, "--server-response";
 662                 push @args, "--post-file=$infile";
 663                 push @args, $submit_url;
 664                 system @args;
 665 #::logDebug("wget cmd line: " . join(" ", @args));
 666                 if($?) {
 667                         $result{reply_os_error} = $!;
 668                         $result{reply_os_status} = $?;
 669                         $result{result_page} = 'FAILED';
 670                 }
 671                 else {
 672 #::logDebug("wget finished.");
 673                         open WOUT, "< $outfile"
 674                                 or die errmsg("Cannot read wget output from %s: %s", $outfile, $!) . "\n";
 675                         $result{result_page} = <WOUT>;
 676                         close WOUT
 677                                 or die errmsg("Cannot close wget output %s: %s", $outfile, $!) . "\n";
 678                         unlink $outfile unless $opt->{debug};
 679                 }
 680
 681                 seek(WIN, 0, 0)
 682                         or die errmsg("Cannot seek on wget input file %s: %s", $infile, $!) . "\n";
 683                 unless($opt->{debug}) {
 684                         my $len = int(length($post) / 8) + 1;
 685                         print WIN 'deadbeef' x $len;
 686                 }
 687
 688                 close WIN
 689                         or die errmsg("Cannot close wget post input file %s: %s", $infile, $!) . "\n";
 690                 unlink $infile unless $opt->{debug};
 691                 open WSTAT, "< $statfile"
 692                         or die errmsg("Cannot read wget status from %s: %s", $statfile, $!) . "\n";
 693                 my $err = <WSTAT>;
 694                 close WSTAT
 695                         or die errmsg("Cannot close wget status %s: %s", $statfile, $!) . "\n";
 696
 697                 unlink $statfile unless $opt->{debug};
 698                 $result{wget_output} = $err;
 699                 $err =~ s/.*HTTP\s+request\s+sent,\s+awaiting\s+response[.\s]*//s;
 700                 my @raw = split /\r?\n/, $err;
 701                 my @head;
 702                 for(@raw) {
 703                         s/^\s*\d+\s*//
 704                                 or last;
 705                         push @head, $_;
 706                 }
 707                 $result{status_line} = shift @head;
 708                 $result{status_line} =~ /^HTTP\S+\s+(\d+)/
 709                         and $result{response_code} = $1;
 710                 $result{header_string} = join "\n", @head;
 711         }
 712         elsif($opt->{use_net_ssleay} or ! $opt->{use_crypt_ssl} && $Have_Net_SSLeay) {
 713 #::logDebug("placing Net::SSLeay request: host=$server, port=$port, script=$script");
 714 #::logDebug("values: " . ::uneval($query) );
 715                 my ($page, $response, %reply_headers)
 716                 = post_https(
 717                                            $server, $port, $script,
 718                            make_headers( %header ),
 719                        make_form(    %$query ),
 720                                         );
 721                 my $header_string = '';
 722
 723                 for(keys %reply_headers) {
 724                         $header_string .= "$_: $reply_headers{$_}\n";
 725                 }
 726 #::logDebug("received Net::SSLeay header: $header_string");
 727                 $result{status_line} = $response;
 728                 $result{status_line} =~ /^HTTP\S+\s+(\d+)/
 729                         and $result{response_code} = $1;
 730                 $result{header_string} = $header_string;
 731                 $result{result_page} = $page;
 732         }
 733         else {
 734                 my @query = %{$query};
 735                 my $ua = new LWP::UserAgent;
 736                 my $req = POST($submit_url, \@query, %header);
 737 #::logDebug("placing LWP request: " . ::uneval_it($req) );
 738                 my $resp = $ua->request($req);
 739                 $result{status_line} = $resp->status_line();
 740                 $result{status_line} =~ /(\d+)/
 741                         and $result{response_code} = $1;
 742                 $result{header_string} = $resp->as_string();
 743                 $result{header_string} =~ s/\r?\n\r?\n.*//s;
 744 #::logDebug("received LWP header: $header_string");
 745                 $result{result_page} = $resp->content();
 746         }
 747 #::logDebug("returning thing: " . ::uneval(\%result) );
 748         return \%result;
 749 }
 750
 751
 752 1;
 753 __END__