t/helper/object.t

   1 use strict;
   2 use Test::More tests => 37;
   3
   4 use lib 't';
   5
   6 # to test delegate, test a few of these combinations:
   7 #   target_class or object
   8 #   target_method given or not
   9 #   object or class invocation
  10
  11 { package T::Helper::Object::Delegatee;
  12   sub test_simple { "simple" }
  13   sub test_class { "classic" }
  14   sub test_invocation { (ref $_[0] ? ref $_[0] : $_[0]) eq __PACKAGE__ }
  15   sub test_method { !!ref $_[0] }
  16   sub test_wantarray {
  17     if (!defined wantarray) {
  18       ${$_[1]} = 'void';
  19     } else {
  20       ${$_[1]} = wantarray ? 'list' : 'scalar';
  21     }
  22   }
  23   sub args { @_ }
  24 }
  25 my $delegatee = bless {}, "T::Helper::Object::Delegatee";
  26
  27 {
  28   package T::Helper::Object::Test1;
  29   use SL::Helper::Object (
  30     delegate => [
  31       obj => [ "test_simple", "test_invocation", "test_method", "test_wantarray", "args" ],
  32       obj => [ { target_method => "test_simple" }, "test_simple_renamed" ],
  33       "T::Helper::Object::Delegatee" => [ "test_class" ],
  34       "T::Helper::Object::Delegatee" => [ { target_method => "test_class" }, "test_class_renamed" ],
  35       "T::Helper::Object::Delegatee" => [ { target_method => "test_invocation" }, "test_class_invocation" ],
  36       "T::Helper::Object::Delegatee" => [ { target_method => "test_method" }, "test_function" ],
  37       obj => [ { target_method => 'test_wantarray', force_context => 'void' },   'test_void_context' ],
  38       obj => [ { target_method => 'test_wantarray', force_context => 'scalar' }, 'test_scalar_context' ],
  39       obj => [ { target_method => 'test_wantarray', force_context => 'list' },   'test_list_context' ],
  40       obj => [ { target_method => 'args', args => 'none' }, 'no_args' ],
  41       obj => [ { target_method => 'args', args => 'raw' }, 'raw_args' ],
  42       obj => [ { target_method => 'args', args => 'standard' }, 'standard_args' ],
  43       "T::Helper::Object::Delegatee" => [ { target_method => "args", args => 'raw' }, "raw_class_args" ],
  44       "T::Helper::Object::Delegatee" => [ { target_method => "args", args => 'standard' }, "standard_class_args" ],
  45       "T::Helper::Object::Delegatee" => [ { target_method => "args", args => 'standard', class_function => 1 }, "class_function_args" ],
  46     ],
  47   );
  48   sub obj { $_[0]{obj} }
  49 };
  50 my $obj1 = bless { obj => $delegatee }, "T::Helper::Object::Test1";
  51
  52 is $obj1->test_simple,           'simple',  'simple delegation works';
  53 is $obj1->test_simple_renamed,   'simple',  'renamed delegation works';
  54 is $obj1->test_class,            'classic', 'class delegation works';
  55 is $obj1->test_class_renamed,    'classic', 'renamed class delegation works';
  56 ok $obj1->test_invocation,       'object invocation works';
  57 ok $obj1->test_class_invocation, 'class invocation works';
  58 ok $obj1->test_method,           'method invocation works';
  59 ok !$obj1->test_function,        'function invocation works';
  60
  61
  62 #  3: args in [ none, raw,standard ]
  63
  64 is scalar $obj1->no_args("test"), 1, 'args none ignores args';
  65 is [$obj1->raw_args("test")]->[0], $delegatee, 'args raw 1';
  66 is [$obj1->raw_args("test")]->[1], $obj1,      'args raw 2';
  67 is [$obj1->raw_args("test")]->[2], "test",     'args raw 3';
  68 is scalar $obj1->raw_args("test"), 3, 'args raw args list';
  69 is [$obj1->standard_args("test")]->[0], $delegatee, 'args standard 1';
  70 is [$obj1->standard_args("test")]->[1], "test",     'args standard 1';
  71 is scalar $obj1->standard_args("test"), 2, 'args standard args list';
  72
  73 is [$obj1->raw_class_args("test")]->[0], ref $delegatee, 'args raw 1';
  74 is [$obj1->raw_class_args("test")]->[1], $obj1,          'args raw 2';
  75 is [$obj1->raw_class_args("test")]->[2], "test",         'args raw 3';
  76 is scalar $obj1->raw_class_args("test"), 3, 'args raw args list';
  77 is [$obj1->standard_class_args("test")]->[0], ref $delegatee, 'args standard 1';
  78 is [$obj1->standard_class_args("test")]->[1], "test",         'args standard 1';
  79 is scalar $obj1->standard_class_args("test"), 2, 'args standard args list';
  80
  81 is [$obj1->class_function_args("test")]->[0], 'test', 'args class function standard 1';
  82 is scalar $obj1->class_function_args("test"), 1, 'args class function standard args list';
  83
  84
  85 #  4: force_context [ none, void, scalar, list ]
  86
  87 my $c;
  88 $c = ''; $obj1->test_void_context(\$c);   is $c, 'void',   'force context void works';
  89 $c = ''; $obj1->test_scalar_context(\$c); is $c, 'scalar', 'force context scalar works';
  90 $c = ''; $obj1->test_list_context(\$c);   is $c, 'list',   'force context list works';
  91
  92 # and without forcing:
  93 $c = ''; $obj1->test_wantarray(\$c);            is $c, 'void',   'natural context void works';
  94 $c = ''; my $test = $obj1->test_wantarray(\$c); is $c, 'scalar', 'natural context scalar works';
  95 $c = ''; my @test = $obj1->test_wantarray(\$c); is $c, 'list',   'natural context list works';
  96
  97
  98 # try stupid stuff that should die
  99
 100 my $dies = 1;
 101 eval { package T::Helper::Object::Test2;
 102   SL::Helper::Object->import(
 103     delegate => [ one => [], "two" ],
 104   );
 105   $dies = 0;
 106   1;
 107 };
 108 ok $dies, 'delegate with uneven number of args dies';
 109
 110 $dies = 1;
 111 eval { package T::Helper::Object::Test3;
 112   SL::Helper::Object->import(
 113     delegate => {},
 114   );
 115   $dies = 0;
 116   1;
 117 };
 118 ok $dies, 'delegate with hashref dies';
 119
 120 $dies = 1;
 121 eval { package T::Helper::Object::Test4;
 122   SL::Helper::Object->import(
 123     delegate => [
 124       "List::Util" => [ '{}; print "gotcha"' ],
 125     ],
 126   );
 127   $dies = 0;
 128   1;
 129 };
 130 ok $dies, 'code injection in method names dies';
 131
 132 $dies = 1;
 133 eval { package T::Helper::Object::Test5;
 134   SL::Helper::Object->import(
 135     delegate => [
 136       "print 'this'" => [ 'test' ],
 137     ],
 138   );
 139   $dies = 0;
 140   1;
 141 };
 142 ok $dies, 'code injection in target dies';
 143
 144 $dies = 1;
 145 eval { package T::Helper::Object::Test6;
 146   SL::Helper::Object->import(
 147     delegate => [
 148       "List::Util" => [ { target_method => 'system()' }, 'test' ],
 149     ],
 150   );
 151   $dies = 0;
 152   1;
 153 };
 154 ok $dies, 'code injection in target_method dies';
 155
 156 $dies = 1;
 157 eval { package T::Helper::Object::Test6;
 158   SL::Helper::Object->import(
 159     delegate => [
 160       "List::Util" => [ { target_name => 'test2' }, 'test' ],
 161     ],
 162   );
 163   $dies = 0;
 164   1;
 165 };
 166 ok $dies, 'unknown parameter dies';
 167
 168 1;