kivitendo/SL/Helper/Object.pm @ 8496b280
| 963330cc | Sven Schöling | 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 "
|
||||
| f7c3193b | Moritz Bunkus | sub ${caller}::$method {
|
||
| 963330cc | Sven Schöling | $pre_context $target_code$method_joiner$target_method$args_string; $post_context
|
||
}
|
||||
1;
|
||||
| e62747c3 | Sven Schöling | " or die "could not create ${caller}::$method: $@";
|
||
| 963330cc | Sven Schöling | }
|
||
}
|
||||
}
|
||||
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
|
||||
| 02752d70 | Geoffrey Richardson | Sick of writing getter, setter? No because Rose::Object::MakeMethods has you covered.
|
||
| 963330cc | Sven Schöling | |||
| 02752d70 | Geoffrey Richardson | Sick of writing all the rest that Rose can't do? Put it here. Functionality in this
|
||
| 963330cc | Sven Schöling | 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
|