package Params::CallbackRequest;
use strict;
use Params::Validate ();
use Params::CallbackRequest::Exceptions (abbr => [qw(throw_bad_params
throw_bad_key
throw_cb_exec)]);
use vars qw($VERSION);
$VERSION = '1.20';
BEGIN {
for my $attr (qw( default_priority
default_pkg_key
redirected )) {
no strict 'refs';
*{$attr} = sub { $_[0]->{$attr} };
}
}
Params::Validate::validation_options
( on_fail => sub { throw_bad_params join '', @_ } );
# We'll use this code reference for cb_classes parameter validation.
my $valid_cb_classes = sub {
# Just return true if they use the string "ALL".
return 1 if $_[0] eq 'ALL';
# Return false if it isn't an array.
return unless ref $_[0] || '' eq 'ARRAY';
# Return true if the first value isn't the string "_ALL_";
return 1 if $_[0]->[0] ne '_ALL_';
# Return false if there's more than one element in the array.
return if @{$_[0]} > 1;
# Just return true.
return 1;
};
# This is our default exception handler.
my $exception_handler = sub {
my $err = shift;
rethrow_exception($err) if ref $err;
throw_cb_exec error => "Error thrown by callback: $err",
callback_error => $err;
};
# Set up the valid parameters to new().
my %valid_params = (
default_priority => {
type => Params::Validate::SCALAR,
callbacks => {
'valid priority' => sub { $_[0] =~ /^\d$/ }
},
default => 5,
},
default_pkg_key => {
type => Params::Validate::SCALAR,
default => 'DEFAULT',
},
callbacks => {
type => Params::Validate::ARRAYREF,
optional => 1,
},
pre_callbacks => {
type => Params::Validate::ARRAYREF,
optional => 1,
},
post_callbacks => {
type => Params::Validate::ARRAYREF,
optional => 1,
},
cb_classes => {
type => Params::Validate::ARRAYREF | Params::Validate::SCALAR,
callbacks => { 'valid cb_classes' => $valid_cb_classes },
optional => 1,
},
ignore_nulls => {
type => Params::Validate::BOOLEAN,
default => 0,
},
exception_handler => {
type => Params::Validate::CODEREF,
default => $exception_handler
},
leave_notes => {
type => Params::Validate::BOOLEAN,
default => 0,
},
);
BEGIN {
# Load up any callback class definitions.
require Params::Callback;
Params::Callback::_find_names();
}
sub new {
my $proto = shift;
my %p = Params::Validate::validate(@_, \%valid_params);
# Grab any class callback specifications.
@p{qw(_cbs _pre _post)} = Params::Callback->_load_classes($p{cb_classes})
if $p{cb_classes};
# Process parameter-triggered callback specs.
if (my $cb_specs = delete $p{callbacks}) {
my %cbs;
foreach my $spec (@$cb_specs) {
# Set the default package key.
$spec->{pkg_key} ||= $p{default_pkg_key};
# Make sure that we have a callback key.
throw_bad_params "Missing or invalid callback key"
unless $spec->{cb_key};
# Make sure that we have a valid priority.
if (defined $spec->{priority}) {
throw_bad_params "Not a valid priority: '$spec->{priority}'"
unless $spec->{priority} =~ /^\d$/;
} else {
# Or use the default.
$spec->{priority} = $p{default_priority};
}
# Make sure that we have a code reference.
throw_bad_params "Callback for package key '$spec->{pkg_key}' " .
"and callback key '$spec->{cb_key}' not a code reference"
unless ref $spec->{cb} eq 'CODE';
# Make sure that the key isn't already in use.
throw_bad_params "Callback key '$spec->{cb_key}' already used " .
"by package key '$spec->{pkg_key}'"
if $p{_cbs}{$spec->{pkg_key}}->{$spec->{cb_key}};
# Set it up.
$p{_cbs}{$spec->{pkg_key}}->{$spec->{cb_key}} =
{ cb => $spec->{cb}, priority => $spec->{priority} };
}
}
# Now validate and store any request callbacks.
foreach my $type (qw(pre post)) {
if (my $cbs = delete $p{$type . '_callbacks'}) {
my @gcbs;
foreach my $cb (@$cbs) {
# Make it an array unless Params::Callback has already
# done so.
$cb = [$cb, 'Params::Callback']
unless ref $cb eq 'ARRAY';
# Make sure that we have a code reference.
throw_bad_params "Request $type callback not a code reference"
unless ref $cb->[0] eq 'CODE';
push @gcbs, $cb;
}
# Keep 'em.
$p{"_$type"} = \@gcbs;
}
}
# Warn 'em if they're not using any callbacks.
unless ($p{_cbs} or $p{_pre} or $p{_post}) {
require Carp;
Carp::carp("You didn't specify any callbacks.");
}
# Set up the notes hash.
$p{notes} = {};
# Let 'em have it.
return bless \%p, ref $proto || $proto;
}
sub request {
my ($self, $params) = (shift, shift);
return $self unless $params;
throw_bad_params "Parameter '$params' is not a hash reference"
unless UNIVERSAL::isa($params, 'HASH');
# Use an array to store the callbacks according to their priorities. Why
# an array when most of its indices will be undefined? Well, because I
# benchmarked it vs. a hash, and found a very negligible difference when
# the array had only element five filled (with no 6-9 elements) and the
# hash had only one element. Furthermore, in all cases where the array had
# two elements (with the other 8 undef), it outperformed the two-element
# hash every time. But really this just starts to come down to very fine
# differences compared to the work that the callbacks will likely be
# doing, anyway. And in the meantime, the array is just easier to use,
# since the priorities are just numbers, and its easist to unshift and
# push on the request callbacks than to stick them onto a hash. In short,
# the use of arrays is cleaner, easier to read and maintain, and almost
# always just as fast or faster than using hashes. So that's the way it'll
# be.
my (@cbs, %cbhs);
if ($self->{_cbs}) {
foreach my $k (keys %$params) {
# Strip off the '.x' that an tag creates.
(my $chk = $k) =~ s/\.x$//;
if ((my $key = $chk) =~ s/_cb(\d?)$//) {
# It's a callback field. Grab the priority.
my $priority = $1;
# Skip callbacks without values, if necessary.
next if $self->{ignore_nulls} &&
(! defined $params->{$k} || $params->{$k} eq '');
if ($chk ne $k) {
# Some browsers will submit $k.x and $k.y instead of just
# $k for , which is a field that can
# only be submitted once for a given page. So skip it if
# we've already seen this parameter.
next if exists $params->{$chk};
# Otherwise, add the unadorned key to $params with a true
# value.
$params->{$chk} = 1;
}
# Find the package key and the callback key.
my ($pkg_key, $cb_key) = split /\|/, $key, 2;
next unless $pkg_key;
# Find the callback.
my $cb;
my $class = $self->{_cbs}{$pkg_key} or
throw_bad_key error => "No such callback package " .
"'$pkg_key'",
callback_key => $chk;
if (ref $class) {
# It's a functional callback. Grab it.
$cb = $class->{$cb_key}{cb} or
throw_bad_key error => "No callback found for " .
"callback key '$chk'",
callback_key => $chk;
# Get the specified priority if none was included in the
# callback key.
$priority = $class->{$cb_key}{priority}
unless $priority ne '';
$class = 'Params::Callback';
} else {
# It's a method callback. Get it from the class.
$cb = $class->_get_callback($cb_key, \$priority) or
throw_bad_key error => "No callback found for " .
"callback key '$chk'",
callback_key => $chk;
}
# Push the callback onto the stack, along with the parameters
# for the construction of the Params::Callback object that
# will be passed to it.
$cbhs{$class} ||= $class->new( @_,
params => $params,
cb_request => $self );
push @{$cbs[$priority]},
[ $cb, $cbhs{$class},
[ $priority, $cb_key, $pkg_key, $chk, $params->{$k} ]
];
}
}
}
# Put any pre and post request callbacks onto the stack.
if ($self->{_pre} or $self->{_post}) {
my $params = [ @_,
params => $params,
cb_request => $self ];
unshift @cbs,
[ map { [ $_->[0], $cbhs{$_} || $_->[1]->new(@$params), [] ] }
@{$self->{_pre}} ]
if $self->{_pre};
push @cbs,
[ map { [ $_->[0], $cbhs{$_} || $_->[1]->new(@$params), [] ] }
@{$self->{_post}} ]
if $self->{_post};
}
# Now execute the callbacks.
eval {
foreach my $cb_list (@cbs) {
# Skip it if there are no callbacks for this priority.
next unless $cb_list;
foreach my $cb_data (@$cb_list) {
my ($cb, $cbh, $cbargs) = @$cb_data;
# Cheat! But this keeps them read-only for the client.
@{$cbh}{qw(priority cb_key pkg_key trigger_key value)} =
@$cbargs;
# Execute the callback.
$cb->($cbh);
}
}
};
# Clear out the redirected attribute, the status, and notes.
my $redir = delete $self->{redirected};
my $status = delete $self->{_status};
%{$self->{notes}} = () unless $self->{leave_notes};
if (my $err = $@) {
# Just pass the exception to the exception handler unless it's an
# abort.
return $status if isa_cb_exception($err, 'Abort');
$self->{exception_handler}->($err);
}
# We now return to normal processing.
return $redir ? $status : $self;
}
sub notes {
my $self = shift;
return $self->{notes} unless @_;
my $key = shift;
return @_
? $self->{notes}{$key} = shift
: $self->{notes}{$key};
}
sub clear_notes {
%{shift->{notes}} = ();
}
1;
__END__
=head1 NAME
Params::CallbackRequest - Functional and object-oriented callback architecture
=head1 SYNOPSIS
Functional parameter-triggered callbacks:
use strict;
use Params::CallbackRequest;
# Create a callback function.
sub calc_time {
my $cb = shift;
my $params = $cb->params;
my $val = $cb->value;
$params->{my_time} = localtime($val || time);
}
# Set up a callback request object.
my $cb_request = Params::CallbackRequest->new(
callbacks => [ { cb_key => 'calc_time',
pkg_key => 'myCallbacker',
cb => \&calc_time } ]
);
# Request callback execution.
my %params = ('myCallbacker|calc_time_cb' => 1);
$cb_request->request(\%params);
# Demonstrate the result.
print "The time is $params{my_time}\n";
Or, in a subclass of Params::Callback:
package MyApp::Callback;
use base qw(Params::Callback);
__PACKAGE__->register_subclass( class_key => 'myCallbacker' );
# Set up a callback method.
sub calc_time : Callback {
my $self = shift;
my $params = $self->request_params;
my $val = $cb->value;
$params->{my_time} = localtime($val || time);
}
And then, in your application:
# Load order is important here!
use MyApp::Callback;
use Params::CallbackRequest;
my $cb_request = Params::Callback->new( cb_classes => [qw(myCallbacker)] );
my %params = ('myCallbacker|calc_time_cb' => 1);
$cb_request->request(\%params);
print "The time is $params{my_time}\n";
=begin comment
=head1 ABSTRACT
Params::CallbackRequest provides functional and object-oriented callbacks to
method and function parameters. Callbacks can either be "request callbacks,"
triggered for every call to C method; or can be triggered by
special parameter hash key names. Although potentially useful in any Perl
application, Params::CallbackRequest was designed to be used with web
applications, where the parameters submitted by the browser may be configured
specifically to trigger callbacks on the server.
=end comment
=head1 DESCRIPTION
Params::CallbackRequest provides functional and object-oriented callbacks to
method and function parameters. Callbacks may be either code references
provided to the C constructor, or methods defined in subclasses of
Params::Callback. Callbacks are triggered either for every call to the
Params::CallbackRequest C method, or by specially named keys in the
parameters to C.
The idea behind this module is to provide a sort of plugin architecture for
Perl templating systems. Callbacks are triggered by the contents of a request
to the Perl templating server, before the templating system itself executes.
This approach allows you to carry out logical processing of data submitted
from a form, to affect the contents of the request parameters before they're
passed to the templating system for processing, and even to redirect or abort
the request before the templating system handles it.
=head1 JUSTIFICATION
Why would you want to do this? Well, there are a number of reasons. Some I can
think of offhand include:
=over 4
=item Stricter separation of logic from presentation
While some Perl templating systems enforce separation of application logic
from presentation (e.g., TT, HTML::Template), others do not (e.g.,
HTML::Mason, Apache::ASP). Even in the former case, application logic is often
put into scripts that are executed alongside the presentation templates, and
loaded on-demand under mod_perl. By moving the application logic into Perl
modules and then directing the templating system to execute that code as
callbacks, you obviously benefit from a cleaner separation of application
logic and presentation.
=item Widgitization
Thanks to their ability to preprocess parameters, callbacks enable developers
to develop easier-to-use, more dynamic widgets that can then be used in any
and all templating systems. For example, a widget that puts many related
fields into a form (such as a date selection widget) can have its fields
preprocessed by a callback (for example, to properly combine the fields into a
unified date parameter) before the template that responds to the form
submission gets the data. See L for an example solution for this very problem.
=item Shared Memory
If you run your templating system under mod_perl, callbacks are just Perl
subroutines in modules loaded at server startup time. Thus the memory they
consume is all in the Apache parent process, and shared by the child
processes. For code that executes frequently, this can be much less
resource-intensive than code in templates, since templates are loaded
separately in each Apache child process on demand.
=item Performance
Since they're executed before the templating architecture does much
processing, callbacks have the opportunity to short-circuit the template
processing by doing something else. A good example is redirection. Often the
application logic in callbacks does its thing and then redirects the user to a
different page. Executing the redirection in a callback eliminates a lot of
extraneous processing that would otherwise be executed before the redirection,
creating a snappier response for the user.
=item Testing
Templating system templates are not easy to test via a testing framework such
as Test::Harness. Subroutines in modules, on the other hand, are fully
testable. This means that you can write tests in your application test suite
to test your callback subroutines.
=back
And if those aren't enough reasons, then just consider this: Callbacks are
just I
=head1 USAGE
Params::CallbackRequest supports two different types of callbacks: those
triggered by a specially named parameter keys, and those executed for every
request.
=head2 Parameter-Triggered Callbacks
Parameter-triggered callbacks are triggered by specially named parameter
keys. These keys are constructed as follows: The package name followed by a
pipe character ("|"), the callback key with the string "_cb" appended to it,
and finally an optional priority number at the end. For example, if you
specified a callback with the callback key "save" and the package key "world",
a callback field might be specified like this:
my $params = { "world|save_cb" => 'Save World' };
When the parameters hash $params is passed to Params::CallbackRequest's
C method, the C parameter would trigger the callback
associated with the "save" callback key in the "world" package. If such a
callback hasn't been configured, then Params::CallbackRequest will throw a
Params::CallbackRequest::Exceptions::InvalidKey exception. Here's how to configure a
functional callback when constructing your Params::CallbackRequest object so
that that doesn't happen:
my $cb_request = Params::CallbackRequest->new
( callbacks => [ { pkg_key => 'world',
cb_key => 'save',
cb => \&My::World::save } ] );
With this configuration, the C parameter key will trigger the
execution of the C subroutine during a callback request:
# Execute parameter-triggered callback.
$cb_request->request($params);
=head3 Functional Callback Subroutines
Functional callbacks use a code reference for parameter-triggered callbacks,
and Params::CallbackRequest executes them with a single argument, a
Params::Callback object. Thus, a callback subroutine will generally look
something like this:
sub foo {
my $cb = shift;
# Do stuff.
}
The Params::Callback object provides accessors to data relevant to the
callback, including the callback key, the package key, and the parameter
hash. It also includes an C method. See the
L documentation for all the goodies.
Note that Params::CallbackRequest installs an exception handler during the
execution of callbacks, so if any of your callback subroutines C,
Params::CallbackRequest will throw an Params::Callback::Exception::Execution
exception. If your callback subroutines throw their own exception objects,
Params::CallbackRequest will simply rethrow them. If you don't like this
configuration, use the C parameter to C to install
your own exception handler.
=head3 Object-Oriented Callback Methods
Object-oriented callback methods, which are supported under Perl 5.6 or later,
are defined in subclasses of Params::Callback, and identified by attributes in
their declarations. Unlike functional callbacks, callback methods are not
called with a Params::Callback object, but with an instance of the callback
subclass. These classes inherit all the goodies provided by Params::Callback,
so you can essentially use their instances exactly as you would use the
Params::Callback object in functional callback subroutines. But because
they're subclasses, you can add your own methods and attributes. See
L for all the gory details on
subclassing, along with a few examples. Generally, callback methods will look
like this:
sub foo : Callback {
my $self = shift;
# Do stuff.
}
As with functional callback subroutines, method callbacks are executed with a
custom exception handler. Again, see the C parameter to
install your own exception handler.
B Under mod_perl, it's important that you C