X-Git-Url: http://wagnertech.de/git?p=kivitendo-erp.git;a=blobdiff_plain;f=t%2Fhelper%2Fobject.t;fp=t%2Fhelper%2Fobject.t;h=f61c894c289a7ffd8a116efcb2385edc64eb26e8;hp=0000000000000000000000000000000000000000;hb=53593baa211863fbf66540cf1bcc36c8fb37257f;hpb=deb4d2dbb676d7d6f69dfe7815d6e0cb09bd4a44

diff --git a/t/helper/object.t b/t/helper/object.t
new file mode 100644
index 000000000..f61c894c2
--- /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, 'unknown parameter dies';
+
+1;