t/bop.t

   1 #!/usr/bin/perl
   2 # $Id: bop.t,v 1.7 2006-11-20 04:54:24 plobbes Exp $
   3
   4 use strict;
   5 use warnings;
   6 use Test::More tests => 62;
   7
   8 BEGIN { use_ok("Business::OnlinePayment") or exit; }
   9
  10 {    # fake test driver 1 (no submit method)
  11
  12     package Business::OnlinePayment::MOCK1;
  13     use strict;
  14     use warnings;
  15     use base qw(Business::OnlinePayment);
  16 }
  17
  18 {    # fake test driver 2 (with submit method that dies)
  19
  20     package Business::OnlinePayment::MOCK2;
  21     use strict;
  22     use warnings;
  23     use base qw(Business::OnlinePayment);
  24     sub submit { die("in processor submit\n"); }
  25 }
  26
  27 {    # fake test driver 3 (with submit method)
  28
  29     package Business::OnlinePayment::MOCK3;
  30     use strict;
  31     use warnings;
  32     use base qw(Business::OnlinePayment);
  33     sub submit { return (1); }
  34 }
  35
  36 my $package = "Business::OnlinePayment";
  37 my @drivers = qw(MOCK1 MOCK2 MOCK3);
  38 my $driver  = $drivers[0];
  39
  40 # trick to make use() happy (called in Business::OnlinePayment->new)
  41 foreach my $drv (@drivers) {
  42     $INC{"Business/OnlinePayment/${drv}.pm"} = "testing";
  43 }
  44
  45 {    # new
  46     can_ok( $package, qw(new) );
  47     my $obj;
  48
  49     eval { $obj = $package->new(); };
  50     like( $@, qr/^unspecified processor/, "new() without a processor croaks" );
  51
  52     eval { $obj = $package->new("__BOP BOGUS PROCESSOR__"); };
  53     like( $@, qr/^unknown processor/,
  54         "new() with an unknown processor croaks" );
  55
  56     $obj = $package->new($driver);
  57     isa_ok( $obj, $package );
  58     isa_ok( $obj, $package . "::" . $driver );
  59
  60     # build_subs(%fields)
  61     can_ok(
  62         $obj, qw(
  63           authorization
  64           error_message
  65           failure_status
  66           fraud_detect
  67           is_success
  68           maximum_risk
  69           path
  70           port
  71           require_avs
  72           result_code
  73           server
  74           server_response
  75           test_transaction
  76           transaction_type
  77           )
  78     );
  79
  80     # new (via build_subs) automatically creates accessors for arguments
  81     $obj = $package->new( $driver, "proc1" => "value1" );
  82     can_ok( $package, "proc1" );
  83     can_ok( $obj,     "proc1" );
  84
  85     # new (via build_subs) automatically creates accessors for arguments
  86     $obj = $package->new( $driver, qw(key1 v1 Key2 v2 -Key3 v3 --KEY4 v4) );
  87     can_ok( $package, qw(key1 key2 key3 key4) );
  88     can_ok( $obj,     qw(key1 key2 key3 key4) );
  89
  90     # new makes all accessors lowercase and removes leading dash(es)
  91     is( $obj->key1, "v1", "value of key1   (method key1) is v1" );
  92     is( $obj->key2, "v2", "value of Key2   (method key2) is v2" );
  93     is( $obj->key3, "v3", "value of -Key3  (method key3) is v3" );
  94     is( $obj->key4, "v4", "value of --KEY4 (method key4) is v4" );
  95 }
  96
  97 # XXX
  98 # {    # _risk_detect }
  99
 100 {    # _pre_submit
 101
 102     my $s_orig = Business::OnlinePayment::MOCK3->can("submit");
 103     is( ref $s_orig, "CODE", "MOCK3 submit code ref $s_orig" );
 104
 105     # test to ensure we do not go recursive when wrapping submit
 106     my $obj1   = $package->new("MOCK3");
 107     my $s_new1 = $obj1->can("submit");
 108
 109     isnt( $s_new1, $s_orig, "MOCK3 submit code ref $s_new1 (wrapped)" );
 110     is( $obj1->submit, "1", "MOCK3(obj1) submit returns 1" );
 111
 112     my $obj2   = $package->new("MOCK3");
 113     my $s_new2 = $obj2->can("submit");
 114     is( $obj2->submit, "1", "MOCK3(obj2) submit returns 1" );
 115
 116     # fraud detection failure modes
 117     my $obj   = $package->new("MOCK3");
 118     my $bogus = "__BOGUS_PROCESSOR";
 119     my $valid = "preCharge";
 120
 121     is( $obj->fraud_detect($bogus), $bogus, "fraud_detect set to '$bogus'" );
 122     eval { $obj->submit; };
 123     is( $@, "", "fraud_detect ignores non-existant processors" );
 124
 125     is( $obj->fraud_detect($valid), $valid, "fraud_detect set to '$valid'" );
 126     eval { $obj->submit; };
 127     like( $@, qr/^missing required /, "fraud_detect($valid) missing fields" );
 128
 129     # XXX: more test cases for preCharge needed
 130 }
 131
 132 {    # content
 133     my $obj;
 134
 135     $obj = $package->new($driver);
 136     can_ok( $package, qw(content) );
 137     can_ok( $obj,     qw(content) );
 138
 139     is( $obj->content, (), "default content is empty" );
 140
 141     my %data = qw(k1 v1 type test -k2 v2 K3 v3);
 142     is_deeply( { $obj->content(%data) }, \%data, "content is set properly" );
 143     is( $obj->transaction_type, "test", "content sets transaction_type" );
 144
 145     %data = ( type => undef );
 146     is_deeply( { $obj->content(%data) }, \%data, "content with type=>undef" );
 147     is( $obj->transaction_type, "test", "transaction_type not reset" );
 148 }
 149
 150 {    # required_fields
 151     my $obj = $package->new($driver);
 152     can_ok( $package, qw(required_fields) );
 153     can_ok( $obj,     qw(required_fields) );
 154
 155     is( $obj->required_fields, 0, "no required fields" );
 156
 157     eval { $obj->required_fields("field1"); };
 158     like( $@, qr/^missing required field/, "missing required_fields croaks" );
 159 }
 160
 161 {    # get_fields
 162     my $obj = $package->new($driver);
 163     can_ok( $package, qw(get_fields) );
 164     can_ok( $obj,     qw(get_fields) );
 165
 166     my %data = ( a => 1, b => 2, c => undef, d => 4 );
 167     $obj->content(%data);
 168
 169     my ( @want, %get );
 170
 171     @want = qw(a b);
 172     %get = map { $_ => $data{$_} } @want;
 173     is_deeply( { $obj->get_fields(@want) },
 174         \%get, "get_fields with defined vals" );
 175
 176     @want = qw(a c d);
 177     %get = map { defined $data{$_} ? ( $_ => $data{$_} ) : () } @want;
 178
 179     is_deeply( { $obj->get_fields(@want) },
 180         \%get, "get_fields does not get fields with undef values" );
 181 }
 182
 183 {    # remap_fields
 184     my $obj = $package->new($driver);
 185     can_ok( $package, qw(remap_fields) );
 186     can_ok( $obj,     qw(remap_fields) );
 187
 188     my %data = ( a => 1, b => 2, c => undef, d => 4 );
 189     $obj->content(%data);
 190
 191     my %map = ( a => "Aa", d => "Dd" );
 192     my %get = ( a => 1, Aa => 1, b => 2, c => undef, d => 4, Dd => 4 );
 193
 194     $obj->remap_fields(%map);
 195     is_deeply( { $obj->content }, \%get, "remap_fields" );
 196 }
 197
 198 {    # submit
 199     my $obj = $package->new($driver);
 200     can_ok( $package, qw(submit) );
 201     can_ok( $obj,     qw(submit) );
 202
 203     eval { $obj->submit; };
 204     like( $@, qr/^Processor subclass did not /, "missing submit() croaks" );
 205     is( $obj->can("submit"), $package->can("submit"), "submit unchanged" );
 206
 207     my $mock2 = $package->new("MOCK2");
 208     can_ok( $mock2, qw(submit) );
 209
 210     isnt( $mock2->can("submit"), $package->can("submit"), "submit changed" );
 211     eval { $mock2->submit; };
 212     like( $@, qr/^in processor submit/, "processor submit() is called" );
 213 }
 214
 215 {    # dump_contents
 216     my $obj = $package->new($driver);
 217     can_ok( $package, qw(dump_contents) );
 218     can_ok( $obj,     qw(dump_contents) );
 219 }
 220
 221 {    # build_subs
 222     my $obj;
 223
 224     $obj = $package->new($driver);
 225     can_ok( $package, qw(build_subs) );
 226     can_ok( $obj,     qw(build_subs) );
 227
 228     # build_subs creates accessors for arguments
 229     my %data = qw(key1 v1 Key2 v2 -Key3 v3 --KEY4 v4);
 230     my @subs =
 231       sort { lc( ( $a =~ /(\w+)/ )[0] ) cmp lc( ( $b =~ /(\w+)/ )[0] ) }
 232       keys %data;
 233
 234     $obj->build_subs(@subs);
 235
 236     # perl does not allow dashes ("-") in subroutine names
 237     foreach my $sub (@subs) {
 238         if ( $sub !~ /^\w+/ ) {
 239             is( ref $package->can($sub), "", "$package can NOT $sub" );
 240             is( ref $obj->can($sub),     "", ref($obj) . " can NOT $sub" );
 241         }
 242         else {
 243             can_ok( $package, $sub );
 244             can_ok( $obj,     $sub );
 245             $obj->$sub( $data{$sub} );
 246             is( $obj->$sub, $data{$sub}, "$sub accessor returns $data{$sub}" );
 247         }
 248     }
 249 }