t/bop.t

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