SL/Helper/Object.pm

   1 package SL::Helper::Object;
   2
   3 use strict;
   4
   5 sub import {
   6   my ($class, @args) = @_;
   7
   8   my $caller = (caller)[0];
   9
  10   while (@args > 1) {
  11     my $method = shift @args;
  12     my $args   = shift @args;
  13     die "invalid method '$method' for $class" unless $class->can($method);
  14     $class->$method($caller, $args);
  15   }
  16 }
  17
  18 my %args_string_by_key = (
  19   none     => '',
  20   raw      => '(@_)',
  21   standard => '(@_[1..$#_])',
  22 );
  23
  24 my %pre_context_by_key = (
  25   void   => '',
  26   scalar => 'my $return =',
  27   list   => 'my @return =',
  28 );
  29
  30 my %post_context_by_key = (
  31   void   => 'return',
  32   scalar => '$return',
  33   list   => '@return',
  34 );
  35
  36 my %known_delegate_args = map { $_ => 1 } qw(target_method args force_context class_function);
  37
  38 my $_ident  = '^[a-zA-Z0-9_]+$';
  39 my $_cident = '^[a-zA-Z0-9_:]+$';
  40
  41 sub delegate {
  42   my ($class, $caller, $args) = @_;
  43
  44   die 'delegate needs an array ref of parameters' if 'ARRAY' ne ref $args;
  45   die 'delegate needs an even number of args'     if @$args % 2;
  46
  47   while (@$args > 1) {
  48     my $target        = shift @$args;
  49     my $delegate_args = shift @$args;
  50     my $params = 'HASH' eq ref $delegate_args->[0] ? $delegate_args->[0] : {};
  51
  52     $known_delegate_args{$_} || die "unknown parameter '$_'" for keys %$params;
  53
  54     die "delegate: target '$target' must match /$_cident/" if $target !~ /$_cident/;
  55     die "delegate: target_method '$params->{target_method}' must match /$_ident/" if $params->{target_method} && $params->{target_method} !~ /$_ident/;
  56
  57     my $method_joiner = $params->{class_function} ? '::' : '->';
  58
  59     for my $method (@$delegate_args) {
  60       next if ref $method;
  61
  62       die "delegate: method name '$method' must match /$_ident/" if $method !~ /$_ident/;
  63
  64       my $target_method = $params->{target_method} // $method;
  65
  66       my ($pre_context, $post_context) = ('', '');
  67       if (exists $params->{force_context}) {
  68         $pre_context  = $pre_context_by_key { $params->{force_context} };
  69         $post_context = $post_context_by_key{ $params->{force_context} };
  70         die "invalid context '$params->{force_context}' to force" unless defined $pre_context && defined $post_context;
  71       }
  72
  73       my $target_code = ucfirst($target) eq $target ? $target : "\$_[0]->$target";
  74
  75       my $args_string = $args_string_by_key{ $params->{args} // 'standard' };
  76       die "invalid args handling '$params->{args}'" unless defined $target_code;
  77
  78       eval "
  79         sub ${caller}::$method {
  80           $pre_context $target_code$method_joiner$target_method$args_string; $post_context
  81         }
  82         1;
  83       " or die "could not create ${caller}::$method: $@";
  84     }
  85   }
  86 }
  87
  88
  89
  90 1;
  91
  92 __END__
  93
  94 =encoding utf-8
  95
  96 =head1 NAME
  97
  98 SL::Helper::Object - Meta Object Helper Mixin
  99
 100 =head1 SYNOPSIS
 101
 102   use SL::Helper::Object (
 103     delegate => [
 104       $target => [ qw(method1 method2 method3 ...) ],
 105       $target => [ { DELEGATE_OPTIONS }, qw(method1 method2 method3 ...) ],
 106       ...
 107     ],
 108   );
 109
 110 =head1 DESCRIPTION
 111
 112 Sick of writing getter, setter? No because Rose::Object::MakeMethods has you covered.
 113
 114 Sick of writing all the rest that Rose can't do? Put it here. Functionality in this
 115 mixin is passed as an include parameter, but are still described as functions:
 116
 117 =head1 FUNCTIONS
 118
 119 =over 4
 120
 121 =item C<delegate PARAMS>
 122
 123 Creates a method that delegates to the target. If the target string starts with
 124 a lower case character, the generated code will be called on an object found
 125 within the calling object by calling an accessor. This way, it is possible to
 126 delegate to an object:
 127
 128   delegate => [
 129     backend_obj => [ qw(save) ],
 130   ],
 131
 132 will generate:
 133
 134   sub save {
 135     $_[0]->backend_obj->save
 136   }
 137
 138 If it starts with an upper case letter, it is assumed that it is a class name:
 139
 140   delegate => [
 141     'Backend' => [ qw(save) ],
 142   ],
 143
 144 will generate:
 145
 146   sub save {
 147     Backend->save
 148   }
 149
 150 Possible delegate args are:
 151
 152 =over 4
 153
 154 =item * C<target_method>
 155
 156 Optional. If not given, the generated method will dispatch to the same method
 157 in the target class. If this is not possible, this can be used to overwrite it.
 158
 159 =item * C<args>
 160
 161 Controls how the arguments are passed.
 162
 163 If set to C<none>, the generated code will not bother passing args. This has the benefit
 164 of not needing to splice the caller class out of @_, or to touch @_ at all for that matter.
 165
 166 If set to C<raw>, the generated code will pass @_ without changes. This will
 167 result in the calling class or object being left in the arg, but is fine if the
 168 delegator is called as a function.
 169
 170 If set to C<standard> (which is also the default), the original caller will be
 171 spliced out and replaced with the new calling context.
 172
 173 =item * C<force_context>
 174
 175 Forces the given context on the delegated method. Valid arguments can be
 176 C<void>, C<scalar>, C<list>. Default behaviour simply puts the call at the end
 177 of the sub so that context is propagated.
 178
 179 =item * C<class_function>
 180
 181 If true, the function will be called as a class function instead of a method call.
 182
 183 =back
 184
 185 =back
 186
 187 =head1 BUGS
 188
 189 None yet :)
 190
 191 =head1 AUTHOR
 192
 193 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 194
 195 =cut