From 963330ccde9da7cb7bb390c1c52dbe2e051d67da Mon Sep 17 00:00:00 2001 From: =?utf8?q?Sven=20Sch=C3=B6ling?= Date: Mon, 24 Jul 2017 15:21:46 +0200 Subject: [PATCH] Object Helper: delegate --- SL/Helper/Object.pm | 195 ++++++++++++++++++++++++++++++++++++++++++++ t/helper/object.t | 168 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 363 insertions(+) create mode 100644 SL/Helper/Object.pm create mode 100644 t/helper/object.t diff --git a/SL/Helper/Object.pm b/SL/Helper/Object.pm new file mode 100644 index 000000000..9c0b98625 --- /dev/null +++ b/SL/Helper/Object.pm @@ -0,0 +1,195 @@ +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 + +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 + +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 + +Controls how the arguments are passed. + +If set to C, 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, 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 (which is also the default), the original caller will be +spliced out and replaced with the new calling context. + +=item * C + +Forces the given context on the delegated method. Valid arguments can be +C, C, C. Default behaviour simply puts the call at the end +of the sub so that context is propagated. + +=item * C + +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 Es.schoeling@linet-services.deE + +=cut diff --git a/t/helper/object.t b/t/helper/object.t new file mode 100644 index 000000000..8f4095beb --- /dev/null +++ b/t/helper/object.t @@ -0,0 +1,168 @@ +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; -- 2.20.1