2 # $Id: bop.t,v 1.5 2006-08-31 15:08:16 lawrence Exp $
6 use Test::More tests => 50;
8 BEGIN { use_ok("Business::OnlinePayment") or exit; }
10 { # fake test driver 1
12 package Business::OnlinePayment::MOCK1;
15 use base qw(Business::OnlinePayment);
19 my $package = "Business::OnlinePayment";
22 # trick to make use() happy (called in Business::OnlinePayment->new)
23 $INC{"Business/OnlinePayment/${driver}.pm"} = "testing";
26 can_ok( $package, qw(new) );
29 eval { $obj = $package->new(); };
30 like( $@, qr/^unspecified processor/, "new() without a processor croaks" );
32 eval { $obj = $package->new("__BOP BOGUS PROCESSOR__"); };
33 like( $@, qr/^unknown processor/,
34 "new() with an unknown processor croaks" );
36 $obj = $package->new($driver);
37 isa_ok( $obj, $package );
38 isa_ok( $obj, $package . "::" . $driver );
60 # new (via build_subs) automatically creates accessors for arguments
61 $obj = $package->new( $driver, "proc1" => "value1" );
62 can_ok( $package, "proc1" );
63 can_ok( $obj, "proc1" );
65 # new (via build_subs) automatically creates accessors for arguments
66 $obj = $package->new( $driver, qw(key1 v1 Key2 v2 -Key3 v3 --KEY4 v4) );
67 can_ok( $package, qw(key1 key2 key3 key4) );
68 can_ok( $obj, qw(key1 key2 key3 key4) );
70 # new makes all accessors lowercase and removes leading dash(es)
71 is( $obj->key1, "v1", "value of key1 (method key1) is v1" );
72 is( $obj->key2, "v2", "value of Key2 (method key2) is v2" );
73 is( $obj->key3, "v3", "value of -Key3 (method key3) is v3" );
74 is( $obj->key4, "v4", "value of --KEY4 (method key4) is v4" );
84 $obj = $package->new($driver);
85 can_ok( $package, qw(content) );
86 can_ok( $obj, qw(content) );
88 is( $obj->content, (), "default content is empty" );
90 my %data = qw(k1 v1 type test -k2 v2 K3 v3);
91 is_deeply( { $obj->content(%data) }, \%data, "content is set properly" );
92 is( $obj->transaction_type, "test", "content sets transaction_type" );
94 %data = ( type => undef );
95 is_deeply( { $obj->content(%data) }, \%data, "content with type=>undef" );
96 is( $obj->transaction_type, "test", "transaction_type not reset" );
100 my $obj = $package->new($driver);
101 can_ok( $package, qw(required_fields) );
102 can_ok( $obj, qw(required_fields) );
104 is( $obj->required_fields, 0, "no required fields" );
106 eval { $obj->required_fields("field1"); };
107 like( $@, qr/^missing required field/, "missing required_fields() croaks" );
111 my $obj = $package->new($driver);
112 can_ok( $package, qw(get_fields) );
113 can_ok( $obj, qw(get_fields) );
115 my %data = ( a => 1, b => 2, c => undef, d => 4 );
116 $obj->content(%data);
121 %get = map { $_ => $data{$_} } @want;
122 is_deeply( { $obj->get_fields(@want) },
123 \%get, "get_fields with defined vals" );
126 %get = map { defined $data{$_} ? ( $_ => $data{$_} ) : () } @want;
128 is_deeply( { $obj->get_fields(@want) },
129 \%get, "get_fields does not get fields with undef values" );
133 my $obj = $package->new($driver);
134 can_ok( $package, qw(remap_fields) );
135 can_ok( $obj, qw(remap_fields) );
137 my %data = ( a => 1, b => 2, c => undef, d => 4 );
138 $obj->content(%data);
140 my %map = ( a => "Aa", d => "Dd" );
141 my %get = ( a => 1, Aa => 1, b => 2, c => undef, d => 4, Dd => 4 );
143 $obj->remap_fields(%map);
144 is_deeply( { $obj->content }, \%get, "remap_fields" );
148 my $obj = $package->new($driver);
149 can_ok( $package, qw(submit) );
150 can_ok( $obj, qw(submit) );
153 eval { $obj->submit; };
154 like( $@, qr/^Processor subclass did not /, "missing submit() croaks" );
158 my $obj = $package->new($driver);
159 can_ok( $package, qw(dump_contents) );
160 can_ok( $obj, qw(dump_contents) );
166 $obj = $package->new($driver);
167 can_ok( $package, qw(build_subs) );
168 can_ok( $obj, qw(build_subs) );
170 # build_subs creates accessors for arguments
171 my %data = qw(key1 v1 Key2 v2 -Key3 v3 --KEY4 v4);
173 sort { lc( ( $a =~ /(\w+)/ )[0] ) cmp lc( ( $b =~ /(\w+)/ )[0] ) }
176 $obj->build_subs(@subs);
178 # perl does not allow dashes ("-") in subroutine names
179 foreach my $sub (@subs) {
180 if ( $sub !~ /^\w+/ ) {
181 is( ref $package->can($sub), "", "$package can NOT $sub" );
182 is( ref $obj->can($sub), "", ref($obj) . " can NOT $sub" );
185 can_ok( $package, $sub );
186 can_ok( $obj, $sub );
187 $obj->$sub( $data{$sub} );
188 is( $obj->$sub, $data{$sub}, "$sub accessor returns $data{$sub}" );