Vertreter-Funktion: Im Kundenstamm ausgebaut und Hinweis in M-Konfig
[kivitendo-erp.git] / 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