Revision 963330cc
Von Sven Schöling vor mehr als 7 Jahren hinzugefügt
| SL/Helper/Object.pm | ||
|---|---|---|
|
package SL::Helper::Object;
|
||
|
|
||
|
use strict;
|
||
|
|
||
|
sub import {
|
||
|
my ($class, @args) = @_;
|
||
|
|
||
|
my $caller = (caller)[0];
|
||
|
|
||
|
while (@args > 1) {
|
||
|
my $method = shift @args;
|
||
|
my $args = shift @args;
|
||
|
die "invalid method '$method' for $class" unless $class->can($method);
|
||
|
$class->$method($caller, $args);
|
||
|
}
|
||
|
}
|
||
|
|
||
|
my %args_string_by_key = (
|
||
|
none => '',
|
||
|
raw => '(@_)',
|
||
|
standard => '(@_[1..$#_])',
|
||
|
);
|
||
|
|
||
|
my %pre_context_by_key = (
|
||
|
void => '',
|
||
|
scalar => 'my $return =',
|
||
|
list => 'my @return =',
|
||
|
);
|
||
|
|
||
|
my %post_context_by_key = (
|
||
|
void => 'return',
|
||
|
scalar => '$return',
|
||
|
list => '@return',
|
||
|
);
|
||
|
|
||
|
my %known_delegate_args = map { $_ => 1 } qw(target_method args force_context class_function);
|
||
|
|
||
|
my $_ident = '^[a-zA-Z0-9_]+$';
|
||
|
my $_cident = '^[a-zA-Z0-9_:]+$';
|
||
|
|
||
|
sub delegate {
|
||
|
my ($class, $caller, $args) = @_;
|
||
|
|
||
|
die 'delegate needs an array ref of parameters' if 'ARRAY' ne ref $args;
|
||
|
die 'delegate needs an even number of args' if @$args % 2;
|
||
|
|
||
|
while (@$args > 1) {
|
||
|
my $target = shift @$args;
|
||
|
my $delegate_args = shift @$args;
|
||
|
my $params = 'HASH' eq ref $delegate_args->[0] ? $delegate_args->[0] : {};
|
||
|
|
||
|
$known_delegate_args{$_} || die "unknown parameter '$_'" for keys %$params;
|
||
|
|
||
|
die "delegate: target '$target' must match /$_cident/" if $target !~ /$_cident/;
|
||
|
die "delegate: target_method '$params->{target_method}' must match /$_ident/" if $params->{target_method} && $params->{target_method} !~ /$_ident/;
|
||
|
|
||
|
my $method_joiner = $params->{class_function} ? '::' : '->';
|
||
|
|
||
|
for my $method (@$delegate_args) {
|
||
|
next if ref $method;
|
||
|
|
||
|
die "delegate: method name '$method' must match /$_ident/" if $method !~ /$_ident/;
|
||
|
|
||
|
my $target_method = $params->{target_method} // $method;
|
||
|
|
||
|
my ($pre_context, $post_context) = ('', '');
|
||
|
if (exists $params->{force_context}) {
|
||
|
$pre_context = $pre_context_by_key { $params->{force_context} };
|
||
|
$post_context = $post_context_by_key{ $params->{force_context} };
|
||
|
die "invalid context '$params->{force_context}' to force" unless defined $pre_context && defined $post_context;
|
||
|
}
|
||
|
|
||
|
my $target_code = ucfirst($target) eq $target ? $target : "\$_[0]->$target";
|
||
|
|
||
|
my $args_string = $args_string_by_key{ $params->{args} // 'standard' };
|
||
|
die "invalid args handling '$params->{args}'" unless defined $target_code;
|
||
|
|
||
|
eval "
|
||
|
sub $caller::$method {
|
||
|
$pre_context $target_code$method_joiner$target_method$args_string; $post_context
|
||
|
}
|
||
|
1;
|
||
|
" or die "could not create $caller::$method: $@";
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
|
||
|
|
||
|
|
||
|
1;
|
||
|
|
||
|
__END__
|
||
|
|
||
|
=encoding utf-8
|
||
|
|
||
|
=head1 NAME
|
||
|
|
||
|
SL::Helper::Object - Meta Object Helper Mixin
|
||
|
|
||
|
=head1 SYNOPSIS
|
||
|
|
||
|
use SL::Helper::Object (
|
||
|
delegate => [
|
||
|
$target => [ qw(method1 method2 method3 ...) ],
|
||
|
$target => [ { DELEGATE_OPTIONS }, qw(method1 method2 method3 ...) ],
|
||
|
...
|
||
|
],
|
||
|
);
|
||
|
|
||
|
=head1 DESCRIPTION
|
||
|
|
||
|
Sick of writing getter, setter? No because Rose::Object::MakeMethods got you covered.
|
||
|
|
||
|
Sick of writing all the rest that Rose an't do? Put it here. Functionality in this
|
||
|
mixin is passed as an include parameter, but are still described as functions:
|
||
|
|
||
|
=head1 FUNCTIONS
|
||
|
|
||
|
=over 4
|
||
|
|
||
|
=item C<delegate PARAMS>
|
||
|
|
||
|
Creates a method that delegates to the target. If the target string starts with
|
||
|
a lower case character, the generated code will be called on an object found
|
||
|
within the calling object by calling an accessor. This way, it is possible to
|
||
|
delegate to an object:
|
||
|
|
||
|
delegate => [
|
||
|
backend_obj => [ qw(save) ],
|
||
|
],
|
||
|
|
||
|
will generate:
|
||
|
|
||
|
sub save {
|
||
|
$_[0]->backend_obj->save
|
||
|
}
|
||
|
|
||
|
If it starts with an upper case letter, it is assumed that it is a class name:
|
||
|
|
||
|
delegate => [
|
||
|
'Backend' => [ qw(save) ],
|
||
|
],
|
||
|
|
||
|
will generate:
|
||
|
|
||
|
sub save {
|
||
|
Backend->save
|
||
|
}
|
||
|
|
||
|
Possible delegate args are:
|
||
|
|
||
|
=over 4
|
||
|
|
||
|
=item * C<target_method>
|
||
|
|
||
|
Optional. If not given, the generated method will dispatch to the same method
|
||
|
in the target class. If this is not possible, this can be used to overwrite it.
|
||
|
|
||
|
=item * C<args>
|
||
|
|
||
|
Controls how the arguments are passed.
|
||
|
|
||
|
If set to C<none>, the generated code will not bother passing args. This has the benefit
|
||
|
of not needing to splice the caller class out of @_, or to touch @_ at all for that matter.
|
||
|
|
||
|
If set to C<raw>, the generated code will pass @_ without changes. This will
|
||
|
result in the calling class or object being left in the arg, but is fine if the
|
||
|
delegator is called as a function.
|
||
|
|
||
|
If set to C<standard> (which is also the default), the original caller will be
|
||
|
spliced out and replaced with the new calling context.
|
||
|
|
||
|
=item * C<force_context>
|
||
|
|
||
|
Forces the given context on the delegated method. Valid arguments can be
|
||
|
C<void>, C<scalar>, C<list>. Default behaviour simply puts the call at the end
|
||
|
of the sub so that context is propagated.
|
||
|
|
||
|
=item * C<class_function>
|
||
|
|
||
|
If true, the function will be called as a class function instead of a method call.
|
||
|
|
||
|
=back
|
||
|
|
||
|
=back
|
||
|
|
||
|
=head1 BUGS
|
||
|
|
||
|
None yet :)
|
||
|
|
||
|
=head1 AUTHOR
|
||
|
|
||
|
Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
|
||
|
|
||
|
=cut
|
||
| t/helper/object.t | ||
|---|---|---|
|
use strict;
|
||
|
use Test::More tests => 37;
|
||
|
|
||
|
use lib 't';
|
||
|
|
||
|
# to test delegate, test a few of these combinations:
|
||
|
# target_class or object
|
||
|
# target_method given or not
|
||
|
# object or class invocation
|
||
|
|
||
|
{ package T::Helper::Object::Delegatee;
|
||
|
sub test_simple { "simple" }
|
||
|
sub test_class { "classic" }
|
||
|
sub test_invocation { (ref $_[0] ? ref $_[0] : $_[0]) eq __PACKAGE__ }
|
||
|
sub test_method { !!ref $_[0] }
|
||
|
sub test_wantarray {
|
||
|
if (!defined wantarray) {
|
||
|
${$_[1]} = 'void';
|
||
|
} else {
|
||
|
${$_[1]} = wantarray ? 'list' : 'scalar';
|
||
|
}
|
||
|
}
|
||
|
sub args { @_ }
|
||
|
}
|
||
|
my $delegatee = bless {}, "T::Helper::Object::Delegatee";
|
||
|
|
||
|
{
|
||
|
package T::Helper::Object::Test1;
|
||
|
use SL::Helper::Object (
|
||
|
delegate => [
|
||
|
obj => [ "test_simple", "test_invocation", "test_method", "test_wantarray", "args" ],
|
||
|
obj => [ { target_method => "test_simple" }, "test_simple_renamed" ],
|
||
|
"T::Helper::Object::Delegatee" => [ "test_class" ],
|
||
|
"T::Helper::Object::Delegatee" => [ { target_method => "test_class" }, "test_class_renamed" ],
|
||
|
"T::Helper::Object::Delegatee" => [ { target_method => "test_invocation" }, "test_class_invocation" ],
|
||
|
"T::Helper::Object::Delegatee" => [ { target_method => "test_method" }, "test_function" ],
|
||
|
obj => [ { target_method => 'test_wantarray', force_context => 'void' }, 'test_void_context' ],
|
||
|
obj => [ { target_method => 'test_wantarray', force_context => 'scalar' }, 'test_scalar_context' ],
|
||
|
obj => [ { target_method => 'test_wantarray', force_context => 'list' }, 'test_list_context' ],
|
||
|
obj => [ { target_method => 'args', args => 'none' }, 'no_args' ],
|
||
|
obj => [ { target_method => 'args', args => 'raw' }, 'raw_args' ],
|
||
|
obj => [ { target_method => 'args', args => 'standard' }, 'standard_args' ],
|
||
|
"T::Helper::Object::Delegatee" => [ { target_method => "args", args => 'raw' }, "raw_class_args" ],
|
||
|
"T::Helper::Object::Delegatee" => [ { target_method => "args", args => 'standard' }, "standard_class_args" ],
|
||
|
"T::Helper::Object::Delegatee" => [ { target_method => "args", args => 'standard', class_function => 1 }, "class_function_args" ],
|
||
|
],
|
||
|
);
|
||
|
sub obj { $_[0]{obj} }
|
||
|
};
|
||
|
my $obj1 = bless { obj => $delegatee }, "T::Helper::Object::Test1";
|
||
|
|
||
|
is $obj1->test_simple, 'simple', 'simple delegation works';
|
||
|
is $obj1->test_simple_renamed, 'simple', 'renamed delegation works';
|
||
|
is $obj1->test_class, 'classic', 'class delegation works';
|
||
|
is $obj1->test_class_renamed, 'classic', 'renamed class delegation works';
|
||
|
ok $obj1->test_invocation, 'object invocation works';
|
||
|
ok $obj1->test_class_invocation, 'class invocation works';
|
||
|
ok $obj1->test_method, 'method invocation works';
|
||
|
ok !$obj1->test_function, 'function invocation works';
|
||
|
|
||
|
|
||
|
# 3: args in [ none, raw,standard ]
|
||
|
|
||
|
is scalar $obj1->no_args("test"), 1, 'args none ignores args';
|
||
|
is [$obj1->raw_args("test")]->[0], $delegatee, 'args raw 1';
|
||
|
is [$obj1->raw_args("test")]->[1], $obj1, 'args raw 2';
|
||
|
is [$obj1->raw_args("test")]->[2], "test", 'args raw 3';
|
||
|
is scalar $obj1->raw_args("test"), 3, 'args raw args list';
|
||
|
is [$obj1->standard_args("test")]->[0], $delegatee, 'args standard 1';
|
||
|
is [$obj1->standard_args("test")]->[1], "test", 'args standard 1';
|
||
|
is scalar $obj1->standard_args("test"), 2, 'args standard args list';
|
||
|
|
||
|
is [$obj1->raw_class_args("test")]->[0], ref $delegatee, 'args raw 1';
|
||
|
is [$obj1->raw_class_args("test")]->[1], $obj1, 'args raw 2';
|
||
|
is [$obj1->raw_class_args("test")]->[2], "test", 'args raw 3';
|
||
|
is scalar $obj1->raw_class_args("test"), 3, 'args raw args list';
|
||
|
is [$obj1->standard_class_args("test")]->[0], ref $delegatee, 'args standard 1';
|
||
|
is [$obj1->standard_class_args("test")]->[1], "test", 'args standard 1';
|
||
|
is scalar $obj1->standard_class_args("test"), 2, 'args standard args list';
|
||
|
|
||
|
is [$obj1->class_function_args("test")]->[0], 'test', 'args class function standard 1';
|
||
|
is scalar $obj1->class_function_args("test"), 1, 'args class function standard args list';
|
||
|
|
||
|
|
||
|
# 4: force_context [ none, void, scalar, list ]
|
||
|
|
||
|
my $c;
|
||
|
$c = ''; $obj1->test_void_context(\$c); is $c, 'void', 'force context void works';
|
||
|
$c = ''; $obj1->test_scalar_context(\$c); is $c, 'scalar', 'force context scalar works';
|
||
|
$c = ''; $obj1->test_list_context(\$c); is $c, 'list', 'force context list works';
|
||
|
|
||
|
# and without forcing:
|
||
|
$c = ''; $obj1->test_wantarray(\$c); is $c, 'void', 'natural context void works';
|
||
|
$c = ''; my $test = $obj1->test_wantarray(\$c); is $c, 'scalar', 'natural context scalar works';
|
||
|
$c = ''; my @test = $obj1->test_wantarray(\$c); is $c, 'list', 'natural context list works';
|
||
|
|
||
|
|
||
|
# try stupid stuff that should die
|
||
|
|
||
|
my $dies = 1;
|
||
|
eval { package T::Helper::Object::Test2;
|
||
|
SL::Helper::Object->import(
|
||
|
delegate => [ one => [], "two" ],
|
||
|
);
|
||
|
$dies = 0;
|
||
|
1;
|
||
|
};
|
||
|
ok $dies, 'delegate with uneven number of args dies';
|
||
|
|
||
|
$dies = 1;
|
||
|
eval { package T::Helper::Object::Test3;
|
||
|
SL::Helper::Object->import(
|
||
|
delegate => {},
|
||
|
);
|
||
|
$dies = 0;
|
||
|
1;
|
||
|
};
|
||
|
ok $dies, 'delegate with hashref dies';
|
||
|
|
||
|
$dies = 1;
|
||
|
eval { package T::Helper::Object::Test4;
|
||
|
SL::Helper::Object->import(
|
||
|
delegate => [
|
||
|
"List::Util" => [ '{}; print "gotcha"' ],
|
||
|
],
|
||
|
);
|
||
|
$dies = 0;
|
||
|
1;
|
||
|
};
|
||
|
ok $dies, 'code injection in method names dies';
|
||
|
|
||
|
$dies = 1;
|
||
|
eval { package T::Helper::Object::Test5;
|
||
|
SL::Helper::Object->import(
|
||
|
delegate => [
|
||
|
"print 'this'" => [ 'test' ],
|
||
|
],
|
||
|
);
|
||
|
$dies = 0;
|
||
|
1;
|
||
|
};
|
||
|
ok $dies, 'code injection in target dies';
|
||
|
|
||
|
$dies = 1;
|
||
|
eval { package T::Helper::Object::Test6;
|
||
|
SL::Helper::Object->import(
|
||
|
delegate => [
|
||
|
"List::Util" => [ { target_method => 'system()' }, 'test' ],
|
||
|
],
|
||
|
);
|
||
|
$dies = 0;
|
||
|
1;
|
||
|
};
|
||
|
ok $dies, 'code injection in target_method dies';
|
||
|
|
||
|
$dies = 1;
|
||
|
eval { package T::Helper::Object::Test6;
|
||
|
SL::Helper::Object->import(
|
||
|
delegate => [
|
||
|
"List::Util" => [ { target_name => 'test2' }, 'test' ],
|
||
|
],
|
||
|
);
|
||
|
$dies = 0;
|
||
|
1;
|
||
|
};
|
||
|
ok $dies, 'unkown parameter dies';
|
||
|
|
||
|
1;
|
||
Auch abrufbar als: Unified diff
Object Helper: delegate