/lib/Vend/Payment.pm
Perl | 753 lines | 571 code | 100 blank | 82 comment | 89 complexity | 503f945a1ab2933608db19f917d02509 MD5 | raw file
- # Vend::Payment - Interchange payment processing routines
- #
- # $Id: Payment.pm,v 2.23 2009-03-20 22:15:56 markj Exp $
- #
- # Copyright (C) 2002-2009 Interchange Development Group
- # Copyright (C) 1996-2002 Red Hat, Inc.
- #
- # This program is free software; you can redistribute it and/or modify
- # it under the terms of the GNU General Public License as published by
- # the Free Software Foundation; either version 2 of the License, or
- # (at your option) any later version.
- #
- # This program is distributed in the hope that it will be useful,
- # but WITHOUT ANY WARRANTY; without even the implied warranty of
- # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- # GNU General Public License for more details.
- #
- # You should have received a copy of the GNU General Public
- # License along with this program; if not, write to the Free
- # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
- # MA 02110-1301 USA.
- package Vend::Payment;
- require Exporter;
- $VERSION = substr(q$Revision: 2.23 $, 10);
- @ISA = qw(Exporter);
- @EXPORT = qw(
- charge
- charge_param
- );
- @EXPORT_OK = qw(
- map_actual
- );
- use Vend::Util;
- use Vend::Interpolate;
- use Vend::Order;
- use IO::Pipe;
- use strict;
- use vars qw/$Have_LWP $Have_Net_SSLeay/;
- my $pay_opt;
- my %cyber_remap = (
- qw/
- configfile CYBER_CONFIGFILE
- id CYBERCASH_ID
- mode CYBER_MODE
- host CYBER_HOST
- port CYBER_PORT
- remap CYBER_REMAP
- currency CYBER_CURRENCY
- precision CYBER_PRECISION
- /
- );
- my %ignore_mv_payment = (
- qw/
- gateway 1
- /
- );
- sub charge_param {
- my ($name, $value, $mode) = @_;
- my $opt;
- if($mode) {
- $opt = $Vend::Cfg->{Route_repository}{$mode} ||= {};
- }
- else {
- $opt = $pay_opt ||= {};
- }
- if($name =~ s/^mv_payment_//i) {
- $name = lc $name;
- }
- if(defined $value) {
- return $pay_opt->{$name} = $value;
- }
- # Find if set in route or options
- return $opt->{$name} if defined $opt->{$name};
- # "gateway" and possibly other future options
- return undef if $ignore_mv_payment{$name};
- # Now check Variable space as last resort
- my $uname = "MV_PAYMENT_\U$name";
- return $::Variable->{$uname} if defined $::Variable->{$uname};
- return $::Variable->{$cyber_remap{$name}}
- if defined $::Variable->{$cyber_remap{$name}};
- return undef;
- }
- # Do remapping of payment variables submitted by user
- # Can be changed/extended with remap/MV_PAYMENT_REMAP
- sub map_actual {
- my ($vref, $cref) = (@_);
- $vref = $::Values unless $vref;
- $cref = \%CGI::values unless $cref;
- my @map = qw(
- address
- address1
- address2
- amount
- b_address
- b_address1
- b_address2
- b_city
- b_country
- b_company
- b_fname
- b_lname
- b_name
- b_state
- b_zip
- check_account
- check_acctname
- check_accttype
- check_bankname
- check_checktype
- check_dl
- check_magstripe
- check_number
- check_routing
- check_transit
- city
- comment1
- comment2
- corpcard_type
- country
- cvv2
- email
- company
- fname
- item_code
- item_desc
- lname
- mv_credit_card_cvv2
- mv_credit_card_exp_month
- mv_credit_card_exp_year
- mv_credit_card_number
- mv_order_number
- mv_transaction_id
- name
- origin_zip
- phone_day
- phone_night
- pin
- po_number
- salestax
- shipping
- state
- tax_duty
- tax_exempt
- tender
- zip
- );
- my %map = qw(
- cyber_mode mv_cyber_mode
- comment giftnote
- );
- @map{@map} = @map;
- # Allow remapping of the variable names
- my $remap;
- if( $remap = charge_param('remap') ) {
- $remap =~ s/^\s+//;
- $remap =~ s/\s+$//;
- my (%remap) = split /[\s=]+/, $remap;
- for (keys %remap) {
- $map{$_} = $remap{$_};
- }
- }
- my %actual;
- my $key;
- my %billing_set;
- my @billing_set = qw/
- b_address1
- b_address2
- b_address3
- b_city
- b_state
- b_zip
- b_country
- /;
- my @billing_ind = qw/
- b_address1
- b_city
- /;
- if(my $str = $::Variable->{MV_PAYMENT_BILLING_SET}) {
- @billing_set = grep $_ !~ /\W/, split /[\s,\0]+/, $str;
- }
- if(my $str = $::Variable->{MV_PAYMENT_BILLING_INDICATOR}) {
- @billing_ind = grep $_ !~ /\W/, split /[\s,\0]+/, $str;
- }
- @billing_set{@billing_set} = @billing_set;
- my $no_billing_xfer = 1;
- for(@billing_ind) {
- $no_billing_xfer = 0 unless length($vref->{$_});
- }
- # pick out the right values, need alternate billing address
- # substitution
- foreach $key (keys %map) {
- $actual{$key} = $vref->{$map{$key}} || $cref->{$key};
- my $secondary = $key;
- next unless $secondary =~ s/^b_//;
- if ($billing_set{$key}) {
- next if $no_billing_xfer;
- $actual{$key} = $vref->{$secondary};
- next;
- }
- next if $actual{$key};
- $actual{$key} = $vref->{$map{$secondary}} || $cref->{$map{$secondary}};
- }
- $actual{name} = "$actual{fname} $actual{lname}"
- if $actual{lname};
- $actual{b_name} = "$actual{b_fname} $actual{b_lname}"
- if $actual{b_lname};
- if($actual{b_address1}) {
- $actual{b_address} = "$actual{b_address1}";
- $actual{b_address} .= ", $actual{b_address2}"
- if $actual{b_address2};
- }
- if($actual{address1}) {
- $actual{address} = "$actual{address1}";
- $actual{address} .= ", $actual{address2}"
- if $actual{address2};
- }
- # Do some standard processing of credit card expirations
- $actual{mv_credit_card_exp_month} =~ s/\D//g;
- $actual{mv_credit_card_exp_month} =~ s/^0+//;
- $actual{mv_credit_card_exp_year} =~ s/\D//g;
- $actual{mv_credit_card_exp_year} =~ s/\d\d(\d\d)/$1/;
- $actual{mv_credit_card_reference} = $actual{mv_credit_card_number} =~ s/\D//g;
- $actual{mv_credit_card_reference} =~ s/^(\d\d).*(\d\d\d\d)$/$1**$2/;
- $actual{mv_credit_card_exp_all} = sprintf(
- '%02d/%02d',
- $actual{mv_credit_card_exp_month},
- $actual{mv_credit_card_exp_year},
- );
- $actual{cyber_mode} = charge_param('transaction')
- || $actual{cyber_mode}
- || 'mauthcapture';
-
- return %actual;
- }
- sub gen_order_id {
- my $opt = shift || {};
- if( $opt->{order_id}) {
- # do nothing, already set
- }
- elsif($opt->{counter}) {
- $opt->{order_id} = Vend::Interpolate::tag_counter(
- $opt->{counter},
- { start => $opt->{counter_start} || 100000,
- sql => $opt->{sql_counter},
- },
- );
- }
- else {
- my(@t) = gmtime(time());
- my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = @t;
- $opt->{order_id} = POSIX::strftime("%y%m%d%H%M%S$$", @t);
- }
- return $opt->{order_id};
- }
- sub charge {
- my ($charge_type, $opt) = @_;
- my $pay_route;
- ### We get the payment base information from a route with the
- ### same name as $charge_type if it is there
- if($Vend::Cfg->{Route}) {
- $pay_route = $Vend::Cfg->{Route_repository}{$charge_type} || {};
- }
- else {
- $pay_route = {};
- }
- ### Then we take any payment options set in &charge, [charge ...],
- ### or $Tag->charge
- # $pay_opt is package-scoped but lexical
- $pay_opt = { %$pay_route };
- for(keys %$opt) {
- $pay_opt->{$_} = $opt->{$_};
- }
- # We relocate these to subroutines to standardize
- ### Maps the form variable names to the names needed by the routine
- ### Standard names are defined ala Interchange or MV4.0x, b_name, lname,
- ### etc. with b_varname taking precedence for these. Falls back to lname
- ### if the b_lname is not set
- my (%actual) = map_actual();
- $pay_opt->{actual} = \%actual;
- # We relocate this to a subroutine to standardize. Uses the payment
- # counter if there
- my $orderID = gen_order_id($pay_opt);
- ### Set up the amounts. The {amount} key will have the currency prepended,
- ### e.g. "usd 19.95". {total_cost} has just the cost.
- # Uses the {currency} -> MV_PAYMENT_CURRENCY options if set
- my $currency = charge_param('currency')
- || ($Vend::Cfg->{Locale} && $Vend::Cfg->{Locale}{currency_code})
- || 'usd';
- # Uses the {precision} -> MV_PAYMENT_PRECISION options if set
- my $precision = charge_param('precision') || 2;
- my $penny = charge_param('penny_pricing') || 0;
- my $amount = $pay_opt->{amount} || Vend::Interpolate::total_cost();
- $amount = round_to_frac_digits($amount, $precision);
- $amount = sprintf "%.${precision}f", $amount;
- $amount *= 100 if $penny;
- $pay_opt->{total_cost} = $amount;
- $pay_opt->{amount} = "$currency $amount";
- ###
- ### Finish setting amounts and currency
- # If we have a previous payment amount, delete it but push it on a stack
- #
- my $stack = $Vend::Session->{payment_stack} || [];
- delete $Vend::Session->{payment_result};
- delete $Vend::Session->{cybercash_result}; ### Deprecated
- #::logDebug("Called charge at " . scalar(localtime));
- #::logDebug("Charge caller is " . join(':', caller));
- #::logDebug("mode=$pay_opt->{gateway}");
- #::logDebug("pay_opt=" . ::uneval($pay_opt));
- # Default to the gateway same as charge type if no gateway specified,
- # and set the gateway in the session for logging on completion
- if(! $opt->{gateway}) {
- $pay_opt->{gateway} = charge_param('gateway') || $charge_type;
- }
- #$charge_type ||= $pay_opt->{gateway};
- $Vend::Session->{payment_mode} = $pay_opt->{gateway};
- # See if we are in test mode
- $pay_opt->{test} = charge_param('test');
- # just convenience
- my $gw = $pay_opt->{gateway};
- # See if we are calling a defined GlobalSub payment mode
- my $sub = $Global::GlobalSub->{$gw};
- # Try our predefined modes
- if (! $sub and defined &{"Vend::Payment::$gw"} ) {
- $sub = \&{"Vend::Payment::$gw"};
- }
- # This is the return from all routines
- my %result;
- if($sub) {
- #::logDebug("Charge sub");
- # Calling a defined GlobalSub payment mode
- # Arguments are the passed option hash (if any) and the route hash
- my $pid;
- my $timeout = $pay_opt->{global_timeout} || charge_param('global_timeout');
- %result = eval {
- if ($timeout > 0) {
- my $pipe = IO::Pipe->new;
- unless ($pid = fork) {
- Vend::Server::child_process_dbi_prep();
- $pipe->writer;
- my %rv = $sub->($pay_opt);
- $pipe->print( ::uneval(\%rv) );
- exit;
- }
- $pipe->reader;
- my $to_msg = $pay_opt->{global_timeout_msg}
- || charge_param('global_timeout_msg')
- || 'Due to technical difficulties, your order could not be processed.';
- local $SIG{ALRM} = sub { die "$to_msg\n" };
- alarm $timeout;
- wait;
- alarm 0;
- $pid = undef;
- my $rv = eval join ('', $pipe->getlines);
- return %$rv;
- }
- return $sub->($pay_opt);
- };
- if($@) {
- my $msg = errmsg(
- "payment routine '%s' returned error: %s",
- $charge_type,
- $@,
- );
- kill (KILL => $pid)
- if $pid && kill (0 => $pid);
- ::logError($msg);
- $result{MStatus} = 'died';
- $result{MErrMsg} = $msg;
- }
- }
- elsif($charge_type =~ /^\s*custom\s+(\w+)(?:\s+(.*))?/si) {
- #::logDebug("Charge custom");
- # MV4 and IC4.6.x methods
- my (@args);
- @args = Text::ParseWords::shellwords($2) if $2;
- if(! defined ($sub = $Global::GlobalSub->{$1}) ) {
- ::logError("bad custom payment GlobalSub: %s", $1);
- return undef;
- }
- eval {
- %result = $sub->(@args);
- };
- if($@) {
- my $msg = errmsg(
- "payment routine '%s' returned error: %s",
- $charge_type,
- $@,
- );
- ::logError($msg);
- $result{MStatus} = $msg;
- }
- }
- elsif (
- $actual{cyber_mode} =~ /^minivend_test(?:_(.*))?/
- or
- $charge_type =~ /^internal_test(?:[ _]+(.*))?/
- )
- {
- #::logDebug("Internal test");
- # Test mode....
- my $status = $1 || charge_param('result') || undef;
- # Interchange test mode
- my %payment = ( %$pay_opt );
- &testSetServer ( %payment );
- %result = testsendmserver(
- $actual{cyber_mode},
- 'Order-ID' => $orderID,
- 'Amount' => $amount,
- 'Card-Number' => $actual{mv_credit_card_number},
- 'Card-Name' => $actual{b_name},
- 'Card-Address' => $actual{b_address},
- 'Card-City' => $actual{b_city},
- 'Card-State' => $actual{b_state},
- 'Card-Zip' => $actual{b_zip},
- 'Card-Country' => $actual{b_country},
- 'Card-Exp' => $actual{mv_credit_card_exp_all},
- );
- $result{MStatus} = $status if defined $status;
- }
- else {
- #::logDebug("Unknown charge type");
- my $msg = errmsg("Unknown charge type: %s", $charge_type);
- ::logError($msg);
- $result{MStatus} = $msg;
- }
- push @$stack, \%result;
- $Vend::Session->{payment_result} = \%result;
- $Vend::Session->{payment_stack} = $stack;
- my $svar = charge_param('success_variable') || 'MStatus';
- my $evar = charge_param('error_variable') || 'MErrMsg';
- if($result{$svar} !~ /^success/) {
- $Vend::Session->{payment_error} = $result{$evar};
- if ($result{$evar} =~ /\S/) {
- $Vend::Session->{errors}{mv_credit_card_valid} = $result{$evar};
- }
- $result{'invalid-order-id'} = delete $result{'order-id'}
- if $result{'order-id'};
- }
- elsif($result{$svar} =~ /success-duplicate/) {
- $Vend::Session->{payment_error} = $result{$evar};
- $result{'invalid-order-id'} = delete $result{'order-id'}
- if $result{'order-id'};
- }
- else {
- delete $Vend::Session->{payment_error};
- }
- $Vend::Session->{payment_id} = $result{'order-id'};
- my $encrypt = charge_param('encrypt');
- if($encrypt and $CGI::values{mv_credit_card_number} and $Vend::Cfg->{EncryptKey}) {
- my $prog = charge_param('encrypt_program') || $Vend::Cfg->{EncryptProgram};
- if($prog =~ /pgp|gpg/) {
- $CGI::values{mv_credit_card_force} = 1;
- (
- undef,
- $::Values->{mv_credit_card_info},
- $::Values->{mv_credit_card_exp_month},
- $::Values->{mv_credit_card_exp_year},
- $::Values->{mv_credit_card_exp_all},
- $::Values->{mv_credit_card_type},
- $::Values->{mv_credit_card_error}
- ) = encrypt_standard_cc(\%CGI::values);
- }
- }
- ::logError(
- "Order id for charge type %s: %s",
- $charge_type,
- $Vend::Session->{cybercash_id},
- )
- if $pay_opt->{log_to_error};
- # deprecated
- for(qw/ id error result /) {
- $Vend::Session->{"cybercash_$_"} = $Vend::Session->{"payment_$_"};
- }
- return \%result if $pay_opt->{hash};
- return $result{'order-id'};
- }
- sub testSetServer {
- my %options = @_;
- my $out = '';
- for(sort keys %options) {
- $out .= "$_=$options{$_}\n";
- }
- logError("Test CyberCash SetServer:\n%s\n" , $out);
- 1;
- }
- sub testsendmserver {
- my ($type, %options) = @_;
- my $out ="type=$type\n";
- for(sort keys %options) {
- $out .= "$_=$options{$_}\n";
- }
- logError("Test CyberCash sendmserver:\n$out\n");
- my $oid;
- eval {
- $oid = Vend::Interpolate::tag_counter(
- "$Vend::Cfg->{ScratchDir}/internal_test.payment.number"
- );
- };
- return ('MStatus', 'success', 'order-id', $oid || 'COUNTER_FAILED');
- }
- sub post_data {
- my ($opt, $query) = @_;
- unless ($opt->{use_wget} or $Have_Net_SSLeay or $Have_LWP) {
- die "No Net::SSLeay or Crypt::SSLeay found.\n";
- }
- my $submit_url = $opt->{submit_url};
- my $server;
- my $port = $opt->{port} || 443;
- my $script;
- my $protocol = $opt->{protocol} || 'https';
- if($submit_url) {
- $server = $submit_url;
- $server =~ s{^https://}{}i;
- $server =~ s{(/.*)}{};
- $port = $1 if $server =~ s/:(\d+)$//;
- $script = $1;
- }
- elsif ($opt->{host}) {
- $server = $opt->{host};
- $script = $opt->{script};
- $script =~ s:^([^/]):/$1:;
- $submit_url = join "",
- $protocol,
- '://',
- $server,
- ($port ? ":$port" : ''),
- $script,
- ;
- }
- my %header = ( 'User-Agent' => "Vend::Payment (Interchange version $::VERSION)");
- if($opt->{extra_headers}) {
- for(keys %{$opt->{extra_headers}}) {
- $header{$_} = $opt->{extra_headers}{$_};
- }
- }
- my %result;
- if($opt->{use_wget}) {
- ## Don't worry about OS independence with UNIX wget
- my $bdir = "$Vend::Cfg->{ScratchDir}/wget";
- unless (-d $bdir) {
- mkdir $bdir, 0777
- or do {
- my $msg = "Failed to create directory %s: %s";
- $msg = errmsg($msg, $bdir, $!);
- logError($msg);
- die $msg;
- };
- }
- my $filebase = "$Vend::SessionID.wget";
- my $statfile = Vend::File::get_filename("$filebase.stat", 1, 1, $bdir);
- my $outfile = Vend::File::get_filename("$filebase.out", 1, 1, $bdir);
- my $infile = Vend::File::get_filename("$filebase.in", 1, 1, $bdir);
- my $cmd = $opt->{use_wget} =~ m{/} ? $opt->{use_wget} : 'wget';
- my @post;
- while( my ($k,$v) = each %$query ) {
- $k = hexify($k);
- $v = hexify($v);
- push @post, "$k=$v";
- }
- my $post = join "&", @post;
- open WIN, "> $infile"
- or die errmsg("Cannot create wget post input file %s: %s", $infile, $!) . "\n";
- print WIN $post;
- local($/);
- my @args = $cmd;
- push @args, "--output-file=$statfile";
- push @args, "--output-document=$outfile";
- push @args, "--server-response";
- push @args, "--post-file=$infile";
- push @args, $submit_url;
- system @args;
- #::logDebug("wget cmd line: " . join(" ", @args));
- if($?) {
- $result{reply_os_error} = $!;
- $result{reply_os_status} = $?;
- $result{result_page} = 'FAILED';
- }
- else {
- #::logDebug("wget finished.");
- open WOUT, "< $outfile"
- or die errmsg("Cannot read wget output from %s: %s", $outfile, $!) . "\n";
- $result{result_page} = <WOUT>;
- close WOUT
- or die errmsg("Cannot close wget output %s: %s", $outfile, $!) . "\n";
- unlink $outfile unless $opt->{debug};
- }
- seek(WIN, 0, 0)
- or die errmsg("Cannot seek on wget input file %s: %s", $infile, $!) . "\n";
- unless($opt->{debug}) {
- my $len = int(length($post) / 8) + 1;
- print WIN 'deadbeef' x $len;
- }
- close WIN
- or die errmsg("Cannot close wget post input file %s: %s", $infile, $!) . "\n";
- unlink $infile unless $opt->{debug};
- open WSTAT, "< $statfile"
- or die errmsg("Cannot read wget status from %s: %s", $statfile, $!) . "\n";
- my $err = <WSTAT>;
- close WSTAT
- or die errmsg("Cannot close wget status %s: %s", $statfile, $!) . "\n";
- unlink $statfile unless $opt->{debug};
- $result{wget_output} = $err;
- $err =~ s/.*HTTP\s+request\s+sent,\s+awaiting\s+response[.\s]*//s;
- my @raw = split /\r?\n/, $err;
- my @head;
- for(@raw) {
- s/^\s*\d+\s*//
- or last;
- push @head, $_;
- }
- $result{status_line} = shift @head;
- $result{status_line} =~ /^HTTP\S+\s+(\d+)/
- and $result{response_code} = $1;
- $result{header_string} = join "\n", @head;
- }
- elsif($opt->{use_net_ssleay} or ! $opt->{use_crypt_ssl} && $Have_Net_SSLeay) {
- #::logDebug("placing Net::SSLeay request: host=$server, port=$port, script=$script");
- #::logDebug("values: " . ::uneval($query) );
- my ($page, $response, %reply_headers)
- = post_https(
- $server, $port, $script,
- make_headers( %header ),
- make_form( %$query ),
- );
- my $header_string = '';
- for(keys %reply_headers) {
- $header_string .= "$_: $reply_headers{$_}\n";
- }
- #::logDebug("received Net::SSLeay header: $header_string");
- $result{status_line} = $response;
- $result{status_line} =~ /^HTTP\S+\s+(\d+)/
- and $result{response_code} = $1;
- $result{header_string} = $header_string;
- $result{result_page} = $page;
- }
- else {
- my @query = %{$query};
- my $ua = new LWP::UserAgent;
- my $req = POST($submit_url, \@query, %header);
- #::logDebug("placing LWP request: " . ::uneval_it($req) );
- my $resp = $ua->request($req);
- $result{status_line} = $resp->status_line();
- $result{status_line} =~ /(\d+)/
- and $result{response_code} = $1;
- $result{header_string} = $resp->as_string();
- $result{header_string} =~ s/\r?\n\r?\n.*//s;
- #::logDebug("received LWP header: $header_string");
- $result{result_page} = $resp->content();
- }
- #::logDebug("returning thing: " . ::uneval(\%result) );
- return \%result;
- }
- 1;
- __END__