t/bop.t

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