Object Helper: delegate

diff --git a/SL/Helper/Object.pm b/SL/Helper/Object.pm
new file mode 100644 (file)
index 0000000..9c0b986
--- /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<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

diff --git a/t/helper/object.t b/t/helper/object.t
new file mode 100644 (file)
index 0000000..8f4095b
--- /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;