Bivio::Test::Bean
# Copyright (c) 2002-2014 bivio Software, Inc. All Rights Reserved.
# $Id$
package Bivio::Test::Bean;
use strict;
use Bivio::Base 'Collection.Attributes';
our($AUTOLOAD);
my($_IDI) = __PACKAGE__->instance_data_index;
my($_R) = b_use('IO.Ref');
sub AUTOLOAD {
my($self, @args) = @_;
my($method) = $AUTOLOAD;
$method =~ s/.*:://;
return if $method eq 'DESTROY';
return _callback($self, $method, \@args);
}
sub new {
my(undef, $values) = @_;
b_die('must supply $values')
unless $values;
return shift->SUPER::new(_verify($_R->nested_copy($values)));
}
sub test_bean_register_callback {
my($self, $method, $args, $callback) = @_;
$self->put(_sig($method, $args) => $callback);
return $self;
}
sub _callback {
my($self, $method, $args) = @_;
my($orig_args) = [@$args];
while(1) {
my($sig) = _sig($method, $args);
return ref($self->unsafe_get($sig)) eq 'CODE'
? $self->unsafe_get($sig)->($orig_args)
: wantarray
? @{$self->unsafe_get($sig)}
: $self->unsafe_get($sig)->[0]
if $self->has_keys($sig);
if (@$args) {
pop(@$args);
}
else {
$self->put_unless_exists(
"_warn_$sig",
sub {
# Don't use b_warn, because in AUTOLOAD
Bivio::IO::Alert->warn($sig, ': not found returning nothing');
return 1;
},
);
return wantarray ? () : undef;
}
}
# DOES NOT RETURN
}
sub _sig {
my($method, $args) = @_;
return "$method(" . join(',', @$args) . ')';
}
sub _verify {
my($values) = @_;
while (my($k, $v) = each(%$values)) {
Bivio::Die->die($k, ': invalid key format')
unless $k =~ /^\w+\(.*\)$/s;
Bivio::Die->die($v, ': value for ', $k, ' must be array_ref or code_ref')
unless ref($v) =~ /^(?:ARRAY|CODE)$/s;
}
return $values;
}
1;