1use strict;
2use warnings;
3
4use Carp;
5use Test::More tests => 70;
6
7use RPC::ExtDirect::Test::Util;
8use RPC::ExtDirect::Util;
9use RPC::ExtDirect::Util::Accessor;
10
11# Simple accessors
12
13package Foo;
14
15sub new {
16    my ($class, %params) = @_;
17
18    return bless {%params}, $class;
19}
20
21sub bleh {
22    return RPC::ExtDirect::Util::get_caller_info($_[1]);
23}
24
25# This one is to test existing sub handling
26sub fred {}
27
28RPC::ExtDirect::Util::Accessor::mk_accessors( simple => ['bar', 'baz'] );
29
30package main;
31
32my $foo = Foo->new( bar => 'baz' );
33
34my $res = eval { $foo->bar() };
35
36is $@,   '',    "Simple getter didn't die";
37is $res, 'baz', "Simple getter value match";
38
39$res = eval { $foo->has_bar() };
40
41is $@,   '', "Simple accessor 1 predicate didn't die";
42is $res, 1,  "Simple accessor 1 predicate match";
43
44$res = eval { $foo->has_baz() };
45
46is $@,   '', "Simple accessor 2 predicate didn't die";
47is $res, !1, "Simple accessor 2 predicate match";
48
49$res = eval { $foo->bar('qux'); };
50
51is $@,          '',    "Simple setter didn't die";
52is $res,        $foo,  "Simple setter return the object";
53is $foo->{bar}, 'qux', "Simple setter value match";
54
55$res = eval { $foo->bar() };
56
57is $res, 'qux', "Simple getter after setter value match";
58
59# Existing methods w/o overwrite
60
61eval {
62    RPC::ExtDirect::Util::Accessor::mk_accessors(
63        class  => 'Foo',
64        simple => ['fred'],
65    )
66};
67
68my $regex = qr/^Accessor fred already exists in class Foo/;
69
70like $@, $regex, "Existing method w/o overwrite died";
71
72# Existing methods w/o overwrite but w/ ignore
73
74eval {
75    RPC::ExtDirect::Util::Accessor->mk_accessor(
76        class  => 'Foo',
77        simple => 'fred',
78        ignore => 1,
79    )
80};
81
82is $@, '', "Existing method w/o ovr w/ ignore didn't die";
83
84$foo->fred('frob');
85
86is $foo->fred(), undef, "Existing method w/o ovr w/ ignore didn't ovr";
87
88# Existing methods w/ overwrite
89
90eval {
91    RPC::ExtDirect::Util::Accessor->mk_accessors(
92        class     => 'Foo',
93        simple    => ['fred'],
94        overwrite => 1,
95    );
96};
97
98is $@, '', "Existing method w/ overwrite didn't die";
99
100$foo->fred('blerg');
101
102is $foo->fred(), 'blerg', "Existing method overwritten";
103
104# Complex accessors
105
106package Complex;
107
108our @ISA = qw/ Foo /;
109
110RPC::ExtDirect::Util::Accessor::mk_accessors(
111    complex => [{
112        setter   => 'bar_baz',
113        fallback => 'bar',
114    }, {
115        setter   => 'baz_baz',
116        fallback => 'bar_baz',
117    }]
118);
119
120package main;
121
122my $baz = Complex->new( bar_baz => 'bleh' );
123
124$res = eval { $baz->bar_baz() };
125
126is $@,   '',     "Complex getter w/ specific didn't die";
127is $res, 'bleh', "Complex getter w/ specific value match";
128
129$res = eval { $baz->has_bar_baz() };
130
131is $@,   '', "Complex accessor 1 predicate didn't die";
132is $res, 1,  "Complex accessor 1 predicate match";
133
134$res = eval { $baz->has_baz_baz() };
135
136is $@,   '', "Complex accessor 2 predicate didn't die";
137is $res, !1, "Complex accessor 2 predicate match";
138
139$res = eval { $baz->bar_baz('mumble') };
140
141is $@,              '',       "Complex setter w/ specific didn't die";
142is $res,            $baz,     "Complex setter w/ specific return the object";
143is $baz->{bar_baz}, 'mumble', "Complex setter w/ specific specific object value";
144is $baz->{bar},     undef,    "Complex setter w/ specific default object value";
145
146$baz = Complex->new( bar => 'bloom' );
147
148$res = eval { $baz->bar_baz() };
149
150is $@,   '',      "Complex getter w/ default didn't die";
151is $res, 'bloom', "Complex getter w/ default value match";
152
153$res = eval { $baz->bar_baz('croffle') };
154
155is $@,              '',        "Complex setter didn't die";
156is $res,            $baz,      "Complex setter w/ default return the object";
157is $baz->{bar_baz}, 'croffle', "Complex setter w/ default specific object value";
158is $baz->{bar},     'bloom',   "Complex setter w/ default default object value";
159
160$res = eval { $baz->bar_baz() };
161
162is $@,   '',        "Complex getter after setter didn't die";
163is $res, 'croffle', "Complex getter after setter value match";
164
165$res = eval { $baz->bar() };
166
167is $@,   '',      "Complex getter after setter default didn't die";
168is $res, 'bloom', "Complex getter after setter default value match";
169
170# Caller info retrieval
171
172my $info = $foo->bleh(1);
173
174is $info, "Foo->bleh", "caller info";
175
176# die() message cleaning
177
178eval { die "foo bar" };
179
180my $msg = RPC::ExtDirect::Util::clean_error_message($@);
181
182is $msg, "foo bar", "die() message clean";
183
184# croak() message cleaning
185
186eval { croak "moo fred" };
187
188$msg = RPC::ExtDirect::Util::clean_error_message($@);
189
190is $msg, "moo fred", "croak() message clean";
191
192# Package flags parsing
193
194package Bar;
195
196no warnings;
197
198my @accessors = qw/ scalar_value empty_scalar
199                    array_value empty_array
200                    hash_value empty_hash/;
201
202our $SCALAR_VALUE = 1;
203our $EMPTY_SCALAR;
204
205our @ARRAY_VALUE = qw/foo bar/;
206our @EMPTY_ARRAY;
207
208our %HASH_VALUE = ( foo => 'bar' );
209our %EMPTY_HASH = ();
210
211sub new {
212    my $class = shift;
213
214    return bless {@_}, $class;
215}
216
217RPC::ExtDirect::Util::Accessor::mk_accessors( simple => \@accessors );
218
219package main;
220
221my $tests = [{
222    name   => 'scalar w/ value',
223    regex  => qr/^.*?Bar::SCALAR_VALUE.*?scalar_value/ms,
224    result => 1,
225    flag   => {
226        package => 'Bar',
227        var     => 'SCALAR_VALUE',
228        type    => 'scalar',
229        setter  => 'scalar_value',
230        default => 'foo',
231    },
232}, {
233    name   => 'scalar w/o value',
234    regex  => '', # Should be no warning
235    result => 'bar',
236    flag   => {
237        package => 'Bar',
238        var     => 'EMPTY_SCALAR',
239        type    => 'scalar',
240        setter  => 'empty_scalar',
241        default => 'bar',
242    },
243}, {
244    name   => 'array w/ values',
245    regex  => qr/^.*Bar::ARRAY_VALUE.*?array_value/ms,
246    result => [qw/ foo bar /],
247    flag   => {
248        package => 'Bar',
249        var     => 'ARRAY_VALUE',
250        type    => 'array',
251        setter  => 'array_value',
252        default => [qw/ baz qux /],
253    },
254}, {
255    name   => 'empty array',
256    regex  => '',
257    result => [qw/ moo fuy /],
258    flag   => {
259        package => 'Bar',
260        var     => 'EMPTY_ARRAY',
261        type    => 'array',
262        setter  => 'empty_array',
263        default => [qw/ moo fuy /],
264    },
265}, {
266    name   => 'empty array no default',
267    regex  => '',
268    result => undef,
269    flag   => {
270        package => 'Bar',
271        var     => 'EMPTY_ARRAY',
272        type    => 'array',
273        setter  => 'empty_array',
274    },
275}, {
276    name   => 'hash w/ values',
277    regex  => qr/^.*Bar::HASH_VALUE.*?hash_value/ms,
278    result => { foo => 'bar' },
279    flag   => {
280        package => 'Bar',
281        var     => 'HASH_VALUE',
282        type    => 'hash',
283        setter  => 'hash_value',
284        default => { baz => 'qux' },
285    },
286}, {
287    name   => 'empty hash',
288    regex  => '',
289    result => { mymse => 'fumble' },
290    flag   => {
291        package => 'Bar',
292        var     => 'EMPTY_HASH',
293        type    => 'hash',
294        setter  => 'empty_hash',
295        default => { mymse => 'fumble' },
296    },
297}, {
298    name   => 'empty hash no default',
299    regex  => '',
300    result => undef,
301    flag   => {
302        package => 'Bar',
303        var     => 'EMPTY_HASH',
304        type    => 'hash',
305        setter  => 'empty_hash',
306        default => undef,
307    },
308}];
309
310our $warn_msg;
311
312$SIG{__WARN__} = sub { $warn_msg = shift };
313
314for my $test ( @$tests ) {
315    my $name    = $test->{name};
316    my $regex   = $test->{regex};
317    my $result  = $test->{result};
318    my $flag    = $test->{flag};
319    my $type    = $flag->{type};
320    my $field   = $flag->{setter};
321    my $has_def = exists $flag->{default};
322
323    my $obj = new Bar;
324
325    $warn_msg = '';
326
327    eval { RPC::ExtDirect::Util::parse_global_flags( [$flag], $obj ) };
328
329    is $@, '', "Var $name didn't die";
330
331    if ( $regex ) {
332        like $warn_msg, $regex, "Var $name warning matches";
333    }
334    else {
335        is $warn_msg, '', "Var $name warning empty";
336    }
337
338    my $value = $obj->$field();
339
340    if ( $type eq 'scalar' ) {
341        is ref($value), '', "Var $name type matches";
342        is $value, $result, "Var $name value matches";
343    }
344    else {
345        if ( defined $result ) {
346            is ref($value), uc $type,  "Var $name type matches";
347        }
348        is_deep $value, $result, "Var $name value matches";
349    }
350
351    if ( !$has_def ) {
352        my $predicate = "has_$field";
353
354        is $obj->$predicate(), !1, "Var $name not defaulted";
355    }
356};
357
358my $bar = Bar->new( scalar_value => 'fred' );
359
360my $flag = $tests->[0]->{flag};
361
362RPC::ExtDirect::Util::parse_global_flags( [ $flag ], $bar );
363
364is $bar->scalar_value, 1, "Existing object value overwritten";
365
366