t/bop.t

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