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