package RPC::ExtDirect::Hook;
use strict;
use warnings;
no warnings 'uninitialized'; ## no critic
use B;
use Carp;
use RPC::ExtDirect ();
### PUBLIC CLASS METHOD (CONSTRUCTOR) ###
#
# Instantiate new Hook object
#
sub new {
my ($class, $type, $method_def) = @_;
my $package = $method_def->{package};
my $method = $method_def->{method};
my ($before, $instead, $after)
= map {
RPC::ExtDirect->get_hook(
type => $_,
package => $package,
method => $method,
)
}
qw/ before instead after/;
my $self = bless {}, $class;
@$self{ qw/type method_def before instead after/ }
= ( $type, $method_def, $before, $instead, $after );
return $self->hook ? $self : undef
}
### PUBLIC INSTANCE METHOD ###
#
# Run the hook
#
sub run {
my ($self, $env, $arg, $result, $exception, $method_called) = @_;
my %hook_arg = %{ $self->method_def };
$hook_arg{code} = delete $hook_arg{referent};
my @param_names = @{ $hook_arg{param_names} || [] };
$hook_arg{arg} = $arg;
$hook_arg{env} = $env;
# Result and exception are passed to "after" hook only
@hook_arg{ qw/result exception method_called/ }
= ($result, $exception, $method_called)
if $self->type eq 'after';
@hook_arg{ qw/before instead after/ }
= map { $self->$_ } qw/before instead after/;
# A drop of sugar
my $code = $hook_arg{code};
my $package = $hook_arg{package};
$hook_arg{orig} = sub { $code->($package, @$arg) };
my $hook = $self->hook;
my $hook_pkg = _package_from_coderef($hook);
# By convention, hooks are called as class methods
return $hook->($hook_pkg, %hook_arg);
}
### PUBLIC INSTANCE METHODS ###
#
# Read only getters
#
sub type { shift->{type} }
sub before { shift->{before} }
sub instead { shift->{instead} }
sub after { shift->{after} }
sub method_def { shift->{method_def} }
sub hook {
my ($self) = @_;
my $type = $self->type;
return $self->$type;
}
############## PRIVATE METHODS BELOW ##############
### PRIVATE PACKAGE SUBROUTINE ###
#
# Return package name from coderef
#
sub _package_from_coderef {
my ($code) = @_;
my $pkg = eval { B::svref_2object($code)->GV->STASH->NAME };
return defined $pkg && $pkg ne '' ? $pkg : undef;
}
1;
__END__
=pod
=head1 NAME
RPC::ExtDirect::Hook - Implements Ext.Direct method hooks
=head1 SYNOPSIS
This module is not intended to be used directly.
=head1 AUTHOR
Alexander Tokarev E<lt>tokarev@cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2011-2012 Alexander Tokarev.
This module is free software; you can redistribute it and/or modify it under
the same terms as Perl itself. See L<perlartistic>.
=cut