projekt kivitendo

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

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;