Params-CallbackRequest-1.20000755000765000024 011600551467 15302 5ustar00davidstaff000000000000Params-CallbackRequest-1.20/Build.PL000444000765000024 174011600551467 16735 0ustar00davidstaff000000000000use Module::Build; my $build = Module::Build->new( module_name => 'Params::CallbackRequest', license => 'perl', create_makefile_pl => 'traditional', configure_requires => { 'Module::Build' => '0.2701' }, recommends => { 'Test::Pod' => '1.41' }, build_requires => { 'Test::More' => '0.17', 'Module::Build' => '0.2701', }, requires => { Params::Validate => '0.59', Exception::Class => '1.10', Test::Simple => '0.17', Attribute::Handlers => '0.77', Class::ISA => 0, perl => 5.006, }, meta_merge => { resources => { homepage => 'http://search.cpan.org/dist/Params-CallbackRequest/', bugtracker => 'http://github.com/theory/params-callbackrequest/issues/', repository => 'http://github.com/theory/params-callbackrequest/', } }, ); $build->create_build_script; Params-CallbackRequest-1.20/Changes000444000765000024 1041211600551467 16750 0ustar00davidstaff000000000000Revision history for Perl extension Params::CallbackRequest. 1.20 2011-06-23T05:47:01 - Moved repostitory to [GitHub](https://github.com/theory/params-callbackrequest/). - Switched to a "traditional" `Makefile.PL`. 1.19 2008-06-23T18:00:43 - Fixed a pasto in the "Support" section of the documentaion, and added that section to all of the modules in this distribution. - Fixed Perl 5.6 requirement to be properly detected by earlier Perls. Thanks to Slaven Rezic for testing on Perl 5.5. 1.18 2008-05-03T23:44:20 - Updated POD test to take advantage of Test::Pod 1.20 or later. - Reformatted the code a bit. - Added a link to the Subversion repository. 1.17 2007-03-27T16:21:34 - Updated copyright date. - Now requiring (rather than recommending) Class::ISA and Attribute::Handlers, since the module requires Perl 5.6 or later anyway, and virtually no one will want to use the module without these modules. Test failure report from David Cantrell. 1.16 2007-03-26T21:25:17 - Fixed a bug detecting mod_perl2. Reported by Jimmy Li. - Fixed a bug in the redirect() method under mod_perl2. Report and fix from Jimmy Li. - Added the "configure_requires" parameter to Build.PL and added Test::Pod to the "recommends" parameter. 1.15 2006-05-26T21:28:55 - Added the 'requester' attribute to Params::Callback. This can be specified by passing the 'requester' parameter to request(), and can be anything. 1.14 2006-03-02T20:07:28 - Removed an unnecessary eval block around the loading of Class::ISA and Attribute::Handlers that would prevent the failure of either of those modules to load to propagate. - Fixed typo in the Synopsis spotted by Scott Lanning. - Added support for mod_perl2, as well as mod_perl 1 and mod_perl 1.99. 1.13 2004-04-20T18:29:37 - Apache 2 compatability added thanks to Fred Moyer. 1.12 2004-03-15T15:27:54 - No longer using a Params::Validate callback to transform a value, since that's not a supported feature of Params::Validate and it led to problems on some platforms. 1.11 Wed Oct 8 19:27:32 2003 - Fixed execution of pre and post callbacks so that they execute in the order in which they're declared. Thanks to Perl 5.8.1 for rubbing my nose in this one! 1.10 Mon Sep 8 21:15:42 2003 - Code moved over from MasonX::ApacheHandler::WithCallbacks, which is deprecated. Differences from that class are as follows. - Code from MasonX::ApacheHandler::WithCallbacks has been migrated to Params::CallbackRequest. - Code from MasonX::CallbackHandler has been migrated to Params::Callback. - MasonX::CallbackTester has been removed, since it isn't necessary in a non-mod_perl environment. - Created Params::CallbackRequest::Exceptions to create all of the exception classes used by Params::CallbackRequest. These no longer inherit from HTML::Mason::Exception, of course, but from Exception::Class::Base. - Renamed the "exec_null_cb_values" parameter to "ignore_nulls". It is now false by default, and you pass a true value to enable it. Thus the semantics are the opposite of "exec_null_cb_values", but the result is the same. - Renamed the "cb_exception_handler" to "exception_handler", since it's now obvious that it applies to callbacks. - Changed the request_args() accessor from MasonX::CallbackHandler to params() in Params::Callback, to reflect the idea that this is a generic parameter-triggered callback architecture. - Replaced the ah() accessor, since the callback controller isn't a Mason ApacheHandler anymore, with cb_request() in Params::Callback. - Replaced the "exec_null_cb_values" parameter from MasonX::ApacheHandler::WithCallbaks, which had defaulted to true, with "ignore_nulls" in Params::CallbackRequest, which defaults to false. - Added notes() to manage per-request notes. Pass a true value to the "leave_notes" parameter to new() to allow notes to persist beyond calls to request(). In such cases, use clear_notes() to manually clear the notes. Params-CallbackRequest-1.20/Makefile.PL000444000765000024 122211600551467 17406 0ustar00davidstaff000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.3800 require 5.006; use ExtUtils::MakeMaker; WriteMakefile ( 'NAME' => 'Params::CallbackRequest', 'VERSION_FROM' => 'lib/Params/CallbackRequest.pm', 'PREREQ_PM' => { 'Attribute::Handlers' => '0.77', 'Class::ISA' => 0, 'Exception::Class' => '1.10', 'Module::Build' => '0.2701', 'Params::Validate' => '0.59', 'Test::More' => '0.17', 'Test::Simple' => '0.17' }, 'INSTALLDIRS' => 'site', 'EXE_FILES' => [], 'PL_FILES' => {} ) ; Params-CallbackRequest-1.20/MANIFEST000444000765000024 46111600551467 16551 0ustar00davidstaff000000000000Build.PL Changes lib/Params/Callback.pm lib/Params/CallbackRequest.pm lib/Params/CallbackRequest/Exceptions.pm Makefile.PL MANIFEST This list of files META.json META.yml README.md t/01basic.t t/02priority.t t/03keys.t t/04errors.t t/05object.t t/06object_request.t t/07combined.t t/08apache.t t/09pod.t Params-CallbackRequest-1.20/META.json000444000765000024 355711600551467 17072 0ustar00davidstaff000000000000{ "abstract" : "Functional and object-oriented callback architecture", "author" : [ "David E. Wheeler " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.38, CPAN::Meta::Converter version 2.110440", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Params-CallbackRequest", "prereqs" : { "build" : { "requires" : { "Module::Build" : "0.2701", "Test::More" : "0.17" } }, "configure" : { "requires" : { "Module::Build" : "0.2701" } }, "runtime" : { "recommends" : { "Test::Pod" : "1.41" }, "requires" : { "Attribute::Handlers" : "0.77", "Class::ISA" : 0, "Exception::Class" : "1.10", "Params::Validate" : "0.59", "Test::Simple" : "0.17", "perl" : "5.006" } } }, "provides" : { "Params::Callback" : { "file" : "lib/Params/Callback.pm", "version" : "1.20" }, "Params::CallbackRequest" : { "file" : "lib/Params/CallbackRequest.pm", "version" : "1.20" }, "Params::CallbackRequest::Exceptions" : { "file" : "lib/Params/CallbackRequest/Exceptions.pm", "version" : "1.20" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://github.com/theory/params-callbackrequest/issues/" }, "homepage" : "http://search.cpan.org/dist/Params-CallbackRequest/", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "http://github.com/theory/params-callbackrequest/" } }, "version" : "1.20" } Params-CallbackRequest-1.20/META.yml000444000765000024 221611600551467 16711 0ustar00davidstaff000000000000--- abstract: 'Functional and object-oriented callback architecture' author: - 'David E. Wheeler ' build_requires: Module::Build: 0.2701 Test::More: 0.17 configure_requires: Module::Build: 0.2701 dynamic_config: 1 generated_by: 'Module::Build version 0.38, CPAN::Meta::Converter version 2.110440' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Params-CallbackRequest provides: Params::Callback: file: lib/Params/Callback.pm version: 1.20 Params::CallbackRequest: file: lib/Params/CallbackRequest.pm version: 1.20 Params::CallbackRequest::Exceptions: file: lib/Params/CallbackRequest/Exceptions.pm version: 1.20 recommends: Test::Pod: 1.41 requires: Attribute::Handlers: 0.77 Class::ISA: 0 Exception::Class: 1.10 Params::Validate: 0.59 Test::Simple: 0.17 perl: 5.006 resources: bugtracker: http://github.com/theory/params-callbackrequest/issues/ homepage: http://search.cpan.org/dist/Params-CallbackRequest/ license: http://dev.perl.org/licenses/ repository: http://github.com/theory/params-callbackrequest/ version: 1.20 Params-CallbackRequest-1.20/README.md000444000765000024 345211600551467 16722 0ustar00davidstaff000000000000Params/CallbackRequest version 1.20 =================================== Params::CallbackRequest provides functional and object-oriented callbacks to method and function parameters. Callbacks may be either code references provided to the `new()` constructor, or methods defined in subclasses of Params::Callback. Callbacks are triggered either for every call to the Params::CallbackRequest `execute()` method, or by specially named keys in the parameters to `execute()`. The idea behind this module is to provide a sort of plugin architecture for Perl templating systems. Callbacks are executed 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. Installation ------------ To install this module, type the following: perl Build.PL ./Build ./Build test ./Build install Or, if you don't have Module::Build installed, type the following: perl Makefile.PL make make test make install Dependencies ------------ This module requires these other modules and libraries: * Params::Validate 0.59 or later * Exception::Class 1.10 or later The object-oriented callback interface requires Perl 5.6 or later and these other modules and libraries: * Attribute::Handlers 0.77 or later * Class::ISA The test suite requires: * Test::Simple 0.17 or later Copyright and License --------------------- Copyright 2003-2011 David E. Wheeler. Some Rights Reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Params-CallbackRequest-1.20/lib000755000765000024 011600551467 16050 5ustar00davidstaff000000000000Params-CallbackRequest-1.20/lib/Params000755000765000024 011600551467 17273 5ustar00davidstaff000000000000Params-CallbackRequest-1.20/lib/Params/Callback.pm000444000765000024 11543211600551467 21530 0ustar00davidstaff000000000000package Params::Callback; use strict; require 5.006; use Params::Validate (); use Params::CallbackRequest::Exceptions (abbr => [qw(throw_bad_params)]); use vars qw($VERSION); $VERSION = '1.20'; use constant DEFAULT_PRIORITY => 5; use constant REDIRECT => 302; # Set up an exception to be thrown by Params::Validate, and allow extra # parameters not specified, since subclasses may add others. Params::Validate::validation_options ( on_fail => sub { throw_bad_params join '', @_ }, allow_extra => 1 ); my $is_num = { 'valid priority' => sub { $_[0] =~ /^\d$/ } }; # Use Apache2?::RequestRec for mod_perl 2 use constant APREQ_CLASS => exists $ENV{MOD_PERL_API_VERSION} ? $ENV{MOD_PERL_API_VERSION} >= 2 ? 'Apache2::RequestRec' : 'Apache::RequestRec' : 'Apache'; BEGIN { # The object-oriented interface is only supported with the use of # Attribute::Handlers in Perl 5.6 and later. We'll use Class::ISA # to get a list of all the classes that a class inherits from so # that we can tell ApacheHandler::WithCallbacks that they exist and # are loaded. unless ($] < 5.006) { require Attribute::Handlers; require Class::ISA; } # Build read-only accessors. for my $attr (qw( cb_request params apache_req priority cb_key pkg_key requester trigger_key value )) { no strict 'refs'; *{$attr} = sub { $_[0]->{$attr} }; } *class_key = \&pkg_key; } my %valid_params = ( cb_request => { isa => 'Params::CallbackRequest' }, params => { type => Params::Validate::HASHREF, }, apache_req => { isa => APREQ_CLASS, optional => 1, }, priority => { type => Params::Validate::SCALAR, callbacks => $is_num, optional => 1, desc => 'Priority' }, cb_key => { type => Params::Validate::SCALAR, optional => 1, desc => 'Callback key' }, pkg_key => { type => Params::Validate::SCALAR, optional => 1, desc => 'Package key' }, trigger_key => { type => Params::Validate::SCALAR, optional => 1, desc => 'Trigger key' }, value => { optional => 1, desc => 'Callback value' }, requester => { optional => 1, desc => 'Requesting object' } ); sub new { my $proto = shift; my %p = Params::Validate::validate(@_, \%valid_params); return bless \%p, ref $proto || $proto; } ############################################################################## # Subclasses must use register_subclass() to register the subclass. They can # also use it to set up the class key and a default priority for the subclass, # But base class CLASS_KEY() and DEFAULT_PRIORITY() methods can also be # overridden to do that. my (%priorities, %classes, %pres, %posts, @reqs, %isas, @classes); sub register_subclass { shift; # Not needed. my $class = caller; return unless UNIVERSAL::isa($class, __PACKAGE__) and $class ne __PACKAGE__; my $spec = { default_priority => { type => Params::Validate::SCALAR, optional => 1, callbacks => $is_num }, class_key => { type => Params::Validate::SCALAR, optional => 1 }, }; my %p = Params::Validate::validate(@_, $spec); # Grab the class key. Default to the actual class name. my $ckey = $p{class_key} || $class; # Create the CLASS_KEY method if it doesn't exist already. unless (defined &{"$class\::CLASS_KEY"}) { no strict 'refs'; *{"$class\::CLASS_KEY"} = sub { $ckey }; } $classes{$class->CLASS_KEY} = $class; if (defined $p{default_priority}) { # Override any base class DEFAULT_PRIORITY methods. no strict 'refs'; *{"$class\::DEFAULT_PRIORITY"} = sub { $p{default_priority} }; } # Push the class into an array so that we can be sure to process it in # the proper order later. push @classes, $class; } ############################################################################## # This method is called by subclassed methods that want to be # parameter-triggered callbacks. sub Callback : ATTR(CODE, BEGIN) { my ($class, $symbol, $coderef, $attr, $data, $phase) = @_; # Validate the arguments. At this point, there's only one allowed, # priority. This is to set a priority for the callback method that # overrides that set for the class. my $spec = { priority => { type => Params::Validate::SCALAR, optional => 1, callbacks => $is_num }, }; my %p = Params::Validate::validate(@$data, $spec); # Get the priority. my $priority = exists $p{priority} ? $p{priority} : $class->DEFAULT_PRIORITY; # Store the priority under the code reference. $priorities{$coderef} = $priority; } ############################################################################## # These methods are called by subclassed methods that want to be request # callbacks. sub PreCallback : ATTR(CODE, BEGIN) { my ($class, $symbol, $coderef) = @_; # Just return if we've been here before. This is to prevent hiccups when # mod_perl loads packages twice. return if $pres{$class} and ref $pres{$class}->[0]; # Store a reference to the code in a temporary location and a pointer to # it in the array. push @reqs, $coderef; push @{$pres{$class}}, $#reqs; } sub PostCallback : ATTR(CODE, BEGIN) { my ($class, $symbol, $coderef) = @_; # Just return if we've been here before. This is to prevent hiccups when # mod_perl loads packages twice. return if $posts{$class} and ref $posts{$class}->[0]; # Store a reference to the code in a temporary location and a pointer to # it in the array. push @reqs, $coderef; push @{$posts{$class}}, $#reqs; } ############################################################################## # This method is called by Params::CallbackRequest to find the names of all # the callback methods declared with the PreCallback and PostCallback # attributes (might handle those declared with the Callback attribute at some # point, as well -- there's some of it in CVS Revision 1.21 of # MasonX::CallbackHandler). This is necessary because, in a BEGIN block, the # symbol isn't defined when the attribute callback is called. I would use a # CHECK or INIT block, but mod_perl ignores them. So the solution is to have # the callback methods save the code references for the methods, make sure # that Params::CallbackRequest is loaded _after_ all the classes that inherit # from Params::Callback, and have it call this function to go back and find # the names of the callback methods. The method names will then of course be # used for the callback names. In mod_perl2, we'll likely be able to call this # method from a PerlPostConfigHandler instead of making # Params::CallbackRequest do it, thus relieving the enforced loading order. # http://perl.apache.org/docs/2.0/user/handlers/server.html#PerlPostConfigHandler sub _find_names { foreach my $class (@classes) { # Find the names of the request callback methods. foreach my $type (\%pres, \%posts) { # We've stored an index pointing to each method in the @reqs # array under __TMP in PreCallback() and PostCallback(). for (@{$type->{$class}}) { my $code = $reqs[$_]; # Grab the symbol hash for this code reference. my $sym = Attribute::Handlers::findsym($class, $code) or die "Anonymous subroutines not supported. Make " . "sure that Params::CallbackRequest loads last"; # Params::CallbackRequest wants an array reference. $_ = [ sub { goto $code }, $class, *{$sym}{NAME} ]; } } # Copy any request callbacks from their parent classes. This is to # ensure that rquest callbacks act like methods, even though, # technically, they're not. $isas{$class} = _copy_meths($class); } # We don't need these anymore. @classes = (); @reqs = (); } ############################################################################## # This little gem, called by _find_names(), mimics inheritance by copying the # request callback methods declared for parent class keys into the children. # Any methods declared in the children will, of course, override. This means # that the parent methods can never actually be called, since request # callbacks are called for every request, and thus don't have a class # association. They still get the correct object passed as their first # parameter, however. sub _copy_meths { my $class = shift; my %seen_class; # Grab all of the super classes. foreach my $super (grep { UNIVERSAL::isa($_, __PACKAGE__) } Class::ISA::super_path($class)) { # Skip classes we've already seen. unless ($seen_class{$super}) { # Copy request callback code references. foreach my $type (\%pres, \%posts) { if ($type->{$class} and $type->{$super}) { # Copy the methods, but allow newer ones to override. my %seen_meth; $type->{$class} = [ grep { not $seen_meth{$_->[2]}++ } @{$type->{$class}}, @{$type->{$super}} ]; } elsif ($type->{$super}) { # Just copy the methods. $type->{$class} = [ @{ $type->{$super} } ]; } } $seen_class{$super} = 1; } } # Return an array ref of the super classes. return [keys %seen_class]; } ############################################################################## # This method is called by Params::CallbackRequest to find methods for # callback classes. This is because Params::Callback stores this list of # callback classes, not Params::CallbackRequest. Its arguments are the # callback class, the name of the method (callback), and a reference to the # priority. We'll only assign the priority if it hasn't been assigned one # already -- that is, it hasn't been _called_ with a priority. sub _get_callback { my ($class, $meth, $p) = @_; # Get the callback code reference. my $c = UNIVERSAL::can($class, $meth) or return; # Get the priority for this callback. If there's no priority, it's not # a callback method, so skip it. return unless defined $priorities{$c}; my $priority = $priorities{$c}; # Reformat the callback code reference. my $code = sub { goto $c }; # Assign the priority, if necessary. $$p = $priority unless $$p ne ''; # Create and return the callback. return $code; } ############################################################################## # This method is also called by Params::CallbackRequest, where the cb_classes # parameter passes in a list of callback class keys or the string "ALL" to # indicate that all of the callback classes should have their callbacks loaded # for use by Params::CallbacRequest. sub _load_classes { my ($pkg, $ckeys) = @_; # Just return success if there are no classes to be loaded. return unless defined $ckeys; my ($cbs, $pres, $posts); # Process the class keys in the order they're given, or just do all of # them if $ckeys eq 'ALL' or $ckeys->[0] eq '_ALL_' (checked by # Params::CallbackRequest). foreach my $ckey ( ref $ckeys && $ckeys->[0] ne '_ALL_' ? @$ckeys : keys %classes ) { my $class = $classes{$ckey} or die "Class with class key '$ckey' not loaded. Did you forget use" . " it or to call register_subclass()?"; # Map the class key to the class for the class and all of its parent # classes, all for the benefit of Params::CallbackRequest. $cbs->{$ckey} = $class; foreach my $c (@{$isas{$class}}) { next if $c eq __PACKAGE__; $cbs->{$c->CLASS_KEY} = $c; } # Load request callbacks in the order they're defined. Methods # inherited from parents have already been copied, so don't worry # about them. push @$pres, @{ $pres{$class} } if $pres{$class}; push @$posts, @{ $posts{$class} } if $posts{$class}; } return ($cbs, $pres, $posts); } ############################################################################## sub redirect { my ($self, $url, $wait, $status) = @_; $status ||= REDIRECT; my $cb_request = $self->cb_request; $cb_request->{_status} = $status; $cb_request->{redirected} = $url; if (my $r = $self->apache_req) { $r->method('GET'); $r->headers_in->unset('Content-length'); $r->err_headers_out->add( Location => $url ); } $self->abort($status) unless $wait; } ############################################################################## sub redirected { $_[0]->cb_request->redirected } ############################################################################## sub abort { my ($self, $aborted_value) = @_; $self->cb_request->{_status} = $aborted_value; Params::Callback::Exception::Abort->throw ( error => ref $self . '->abort was called', aborted_value => $aborted_value ); } ############################################################################## sub aborted { my ($self, $err) = @_; $err = $@ unless defined $err; return Params::CallbackRequest::Exceptions::isa_cb_exception( $err, 'Abort' ); } ############################################################################## sub notes { shift->{cb_request}->notes(@_); } 1; __END__ =head1 NAME Params::Callback - Parameter callback base class =head1 SYNOPSIS Functional callback interface: sub my_callback { # Sole argument is a Params::Callback object. my $cb = shift; my $params = $cb->params; my $value = $cb->value; # Do stuff with above data. } Object-oriented callback interface: package MyApp::Callback; use base qw(Params::Callback); use constant CLASS_KEY => 'MyHandler'; use strict; sub my_callback : Callback { my $self = shift; my $params = $self->params; my $value = $self->value; # Do stuff with above data. } =head1 DESCRIPTION Params::Callback provides the interface for callbacks to access parameter hashes Params::CallbackRequest object, and callback metadata, as well as for executing common request actions, such as aborting a callback execution request. There are two ways to use Params::Callback: via functional-style callback subroutines and via object-oriented callback methods. For functional callbacks, a Params::Callback object is constructed by Params::CallbackRequest for each call to its C method, and passed as the sole argument for every execution of a callback function. See L for details on how to create a Params::CallbackRequest object to execute your callback code. In the object-oriented callback interface, Params::Callback is the parent class from which all callback classes inherit. Callback methods are declared in such subclasses via C, C, and C attributes to each method declaration. Methods and subroutines declared without one of these callback attributes are not callback methods, but normal methods or subroutines of the subclass. Read L for details on subclassing Params::Callback. =head1 INTERFACE Params::Callback provides the parameter hash accessors and utility methods that will help manage a callback request (where a "callback request" is considered a single call to the C method on a Params::CallbackRequest object). Functional callbacks always get a Params::Callback object passed as their first argument; the same Params::Callback object will be used for all callbacks in a single request. For object-oriented callback methods, the first argument will of course always be an object of the class corresponding to the class key used in the callback key (or, for request callback methods, an instance of the class for which the request callback method was loaded), and the same object will be reused for all subsequent callbacks to the same class in a single request. =head2 Accessor Methods All of the Params::Callback accessor methods are read-only. Feel free to add other attributes in your Params::Callback subclasses if you're using the object-oriented callback interface. =head3 cb_request my $cb_request = $cb->cb_request; Returns a reference to the Params::CallbackRequest object that executed the callback. =head3 params my $params = $cb->params; Returns a reference to the request parameters hash. Any changes you make to this hash will propagate beyond the lifetime of the request. =head3 apache_req my $r = $cb->apache_req; Returns the Apache request object for the current request, provided you've passed one to C<< Params::CallbackRequest->request >>. This will be most useful in a mod_perl environment, of course. Use Apache:FakeRequest in tests to emmulate the behavior of an Apache request object. =head3 requester my $r = $cb->requester; Returns the object that executed the callback by calling C on a Params::CallbackRequest object. Only available if the C parameter is passed to C<< Params::CallbackRequest->request >>. This can be useful for callbacks to get access to the object that executed the callbacks. =head3 priority my $priority = $cb->priority; Returns the priority level at which the callback was executed. Possible values range from "0" to "9", and may be set by a default priority setting, by the callback configuration or method declaration, or by the parameter callback trigger key. See L for details. =head3 cb_key my $cb_key = $cb->cb_key; Returns the callback key that triggered the execution of the callback. For example, this callback-triggering parameter hash: my $params = { "DEFAULT|save_cb" => 'Save' }; Will cause the C method in the relevant callback to return "save". =head3 pkg_key my $pkg_key = $cb->pkg_key; Returns the package key used in the callback trigger parameter key. For example, this callback-triggering parameter hash: my $params = { "MyCBs|save_cb" => 'Save' }; Will cause the C method in the relevant callback to return "MyCBs". =head3 class_key my $class_key = $cb->class_key; An alias for C, only perhaps a bit more appealing for use in object-oriented callback methods. =head3 trigger_key my $trigger_key = $cb->trigger_key; Returns the complete parameter key that triggered the callback. For example, if the parameter key that triggered the callback looks like this: my $params = { "MyCBs|save_cb6" => 'Save' }; Then the value returned by C method will be "MyCBs|save_cb6". B Most browsers will submit "image" input fields with two arguments, one with ".x" appended to its name, and the other with ".y" appended to its name. Because Params::CallbackRequest is designed to be used with Web form fields populating a parameter hash, it will ignore these fields and either use the field that's named without the ".x" or ".y", or create a field with that name and give it a value of "1". The reasoning behind this approach is that the names of the callback-triggering fields should be the same as the names that appear in the HTML form fields. If you want the actual x and y image click coordinates, access them directly from the request parameters: my $params = $cb->params; my $trigger_key = $cb->trigger_key; my $x = $params->{"$trigger_key.x"}; my $y = $params->{"$trigger_key.y"}; =head3 value my $value = $cb->value; Returns the value of the parameter that triggered the callback. This value can be anything that can be stored in a hash value -- that is, any scalar value. Thus, in this example: my $params = { "DEFAULT|save_cb" => 'Save', "DEFAULT|open_cb" => [qw(one two)] }; C will return the string "Save" in the save callback, but the array reference C<['one', 'two']> in the open callback. Although you may often be able to retrieve the value directly from the hash reference returned by C, if multiple callback keys point to the same subroutine or if the parameter that triggered the callback overrode the priority, you may not be able to determine which value was submitted for a particular callback execution. So Params::Callback kindly provides the value for you. The exception to this rule is values submitted under keys named for HTML "image" input fields. See the note about this under the documentation for the C method. =head3 redirected $cb->redirect($url) unless $cb->redirected; If the request has been redirected, this method returns the redirection URL. Otherwise, it returns false. This method is useful for conditions in which one callback has called C<< $cb->redirect >> with the optional C<$wait> argument set to a true value, thus allowing subsequent callbacks to continue to execute. If any of those subsequent callbacks want to call C<< $cb->redirect >> themselves, they can check the value of C<< $cb->redirected >> to make sure it hasn't been done already. =head2 Other Methods Params::Callback offers has a few other publicly accessible methods. =head3 notes $cb->notes($key => $value); my $val = $cb->notes($key); my $notes = $cb->notes; Shortcut for C<< $cb->cb_request->notes >>. It provides a place to store application data, giving developers a way to share data among multiple callbacks. See L|Params::CallbackRequest/"notes"> for more information. =head3 redirect $cb->redirect($url); $cb->redirect($url, $wait); $cb->redirect($url, $wait, $status); This method can be used to redirect a request in a mod_perl environment, provided that an Apache request object has been passed to C<< Params::CallbackRequest->new >>. Outide of a mod_perl environment or without an Apache request object, C will still set the proper value for the the C method to return, and will still abort the callback request. Given a URL, this method generates a proper HTTP redirect for that URL. By default, the status code used is "302", but this can be overridden via the C<$status> argument. If the optional C<$wait> argument is true, any callbacks scheduled to be executed after the call to C will continue to be executed. In that case, C<< $cb->abort >> will not be called; rather, Params::CallbackRequest will finish executing all remaining callbacks and then return the abort status. If the C<$wait> argument is unspecified or false, then the request will be immediately terminated without executing subsequent callbacks or. This approach relies on the execution of C<< $cb->abort >>. Since C<< $cb->redirect >> calls C<< $cb->abort >>, it will be trapped by an C block. If you are using an C block in your code to trap exceptions, you need to make sure to rethrow these exceptions, like this: eval { ... }; die $@ if $cb->aborted; # handle other exceptions =head3 abort $cb->abort($status); Aborts the current request without executing any more callbacks. The C<$status> argument specifies a request status code to be returned to by C<< Params::CallbackRequest->request() >>. C is implemented by throwing a Params::Callback::Exception::Abort object and can thus be caught by C. The C method is a shortcut for determining whether an exception was generated by C. =head3 aborted die $err if $cb->aborted; die $err if $cb->aborted($err); Returns true or C to indicate whether the specified C<$err> was generated by C. If no C<$err> argument is passed, C examines C<$@>, instead. In this code, we catch and process fatal errors while letting C exceptions pass through: eval { code_that_may_die_or_abort() }; if (my $err = $@) { die $err if $cb->aborted($err); # handle fatal errors... } C<$@> can lose its value quickly, so if you're planning to call C<< $cb->aborted >> more than a few lines after the C, you should save C<$@> to a temporary variable and explicitly pass it to C as in the above example. =head1 SUBCLASSING Under Perl 5.6.0 and later, Params::Callback offers an object-oriented callback interface. The object-oriented approach is to subclass Params::Callback, add the callback methods you need, and specify a class key that uniquely identifies your subclass across all Params::Callback subclasses in your application. The key is to use Perl method attributes to identify methods as callback methods, so that Params::Callback can find them and execute them when the time comes. Here's an example: package MyApp::CallbackHandler; use base qw(Params::Callback); use strict; __PACKAGE__->register_subclass( class_key => 'MyHandler' ); sub build_utc_date : Callback( priority => 2 ) { my $self = shift; my $params = $self->params; $params->{date} = sprintf "%04d-%02d-%02dT%02d:%02d:%02d", delete @{$params}{qw(year month day hour minute second)}; } This parameter-triggered callback can then be executed via a parameter hash such as this: my $params = { "MyHandler|build_utc_date_cb" => 1 }; Think of the part of the name preceding the pipe (the package key) as the class name, and the part of the name after the pipe (the callback key) as the method to call (plus '_cb'). If multiple parameters use the "MyHandler" class key in a single request, then a single MyApp::CallbackHandler object instance will be used to execute each of those callback methods for that request. To configure your Params::CallbackRequest object to use this callback, use its C constructor parameter: my $cb_request = Params::CallbackRequest->new ( cb_classes => [qw(MyHandler)] ); $cb_request->request($params); Now, there are a few of things to note in the above callback class example. The first is the call to C<< __PACKAGE__->register_subclass >>. This step is B in all callback subclasses in order that Params::Callback will know about them, and thus they can be loaded into an instance of a Params::CallbackRequest object via its C constructor parameter. Second, a callback class key B be declared for the class. This can be done either by implementing the C class method or constant in your subclass, or by passing the C parameter to C<< __PACKAGE__->register_subclass >>, which will then create the C method for you. If no callback key is declared, then Params::Callback will throw an exception when you try to load your subclass' callback methods into a Params::CallbackRequest object. One other, optional parameter, C, may also be passed to C. The value of this parameter (an integer between 0 and 9) will be used to create a C class method in the subclass. You can also explicitly implement the C class method or constant in the subclass, if you'd rather. All parameter-triggered callback methods in that class will have their priorities set to the value returned by C, unless they override it via their C attributes. And finally, notice the C attribute on the C method declaration in the example above. This attribute is what identifies C as a parameter-triggered callback. Without the C attribute, any subroutine declaration in your subclass will just be a subroutine or a method; it won't be a callback, and it will never be executed by Params::CallbackRequest. One parameter, C, can be passed via the C attribute. In the above example, we pass C<< priority => 2 >>, which sets the priority for the callback. Without the C parameter, the callback's priority will be set to the value returned by the C class method. Of course, the priority can still be overridden by adding it to the callback trigger key. For example, here we force the callback priority for the execution of the C callback method for this one field to be the highest priority, "0": my $params = { "MyHandler|build_utc_date_cb0" => 1 }; Other parameters to the C attribute may be added in future versions of Params::Callback. Request callbacks can also be implemented as callback methods using the C and C attributes, which currently support no parameters. =head2 Subclassing Examples At this point, you may be wondering what advantage the object-oriented callback interface offer over functional callbacks. There are a number of advantages. First, it allows you to make use of callbacks provided by other users without having to reinvent the wheel for yourself. Say someone has implemented the above class with its exceptionally complex C callback method. You need to have the same functionality, only with fractions of a second added to the date format so that you can insert them into your database without an error. (This is admittedly a contrived example, but you get the idea.) To make it happen, you merely have to subclass the above class and override the C method to do what you need: package MyApp::Callback::Subclass; use base qw(MyApp::CallbackHandler); use strict; __PACKAGE__->register_subclass; # Implement CLASS_KEY ourselves. use constant CLASS_KEY => 'SubHandler'; sub build_utc_date : Callback( priority => 1 ) { my $self = shift; $self->SUPER::build_utc_date; my $params = $self->params; $params->{date} .= '.000000'; } This callback can then be triggered by a parameter hash such as this: my $params = { "SubHandler|build_utc_date_cb" => 1 }; Note that we've used the "SubHandler" class key. If we used the "MyHandler" class key, then the C method would be called on an instance of the MyApp::CallbackHandler class, instead. =head3 Request Callback Methods I'll admit that the case for request callback methods is a bit more tenuous. Granted, a given application may have 100s or even 1000s of parameter-triggered callbacks, but only one or two request callbacks, if any. But the advantage of request callback methods is that they encourage code sharing, in that Params::Callback creates a kind of plug-in architecture Perl templating architectures. For example, say someone has kindly created a Params::Callback subclass, Params::Callback::Unicodify, with the request callback method C, which translates character sets, allowing you to always store data in the database in Unicode. That's all well and good, as far as it goes, but let's say that you want to make sure that your Unicode strings are actually encoded using the Perl C<\x{..}> notation. Again, just subclass: package Params::Callback::Unicodify::PerlEncode; use base qw(Params::Callback::Unicodify); use strict; __PACKAGE__->register_subclass( class_key => 'PerlEncode' ); sub unicodify : PreCallback { my $self = shift; $self->SUPER::unicodify; my $params = $self->params; encode_unicode($params); # Hand waving. } Now you can just tell Params::CallbackRequest to use your subclassed callback handler: my $cb_request = Params::CallbackRequest->new ( cb_classes => [qw(PerlEncode)] ); Yeah, okay, you could just create a second pre-callback request callback to encode the Unicode characters using the Perl C<\x{..}> notation. But you get the idea. Better examples welcome. =head3 Overriding the Constructor Another advantage to using callback classes is that you can override the Params::Callback C constructor. Since every callback for a single class will be executed on the same instance object in a single request, you can set up object properties in the constructor that subsequent callback methods in the same request can then access. For example, say you had a series of pages that all do different things to manage objects in your application. Each of those pages might have a number of parameters in common to assist in constructing an object: my $params = { class => "MyApp::Spring", obj_id => 10, # ... }; Then the remaining parameters created for each of these pages have different key/value pairs for doing different things with the object, perhaps with numerous parameter-triggered callbacks. Here's where subclassing comes in handy: you can override the constructor to construct the object when the callback object is constructed, so that each of your callback methods doesn't have to: package MyApp::Callback; use base qw(Params::Callback); use strict; __PACKAGE__->register_subclass( class_key => 'MyCBHandler' ); sub new { my $class = shift; my $self = $class->SUPER::new(@_); my $params = $self->params; $self->object($params->{class}->lookup( id => $params->{obj_id} )); } sub object { my $self = shift; if (@_) { $self->{object} = shift; } return $self->{object}; } sub save : Callback { my $self = shift; $self->object->save; } =head1 SUBCLASSING INTERFACE Much of the interface for subclassing Params::Callback is evident in the above examples. Here is a reference to the complete callback subclassing API. =head2 Callback Class Declaration Callback classes always subclass Params::Callback, so of course they must always declare such. In addition, callback classes must always call C<< __PACKAGE__->register_subclass >> so that Params::Callback is aware of them and can tell Params::CallbackRequest about them. Second, callback classes B have a class key. The class key can be created either by implementing a C class method or constant that returns the class key, or by passing the C parameter to C method. If no C parameter is passed to C and no C method exists, C will create the C class method to return the actual class name. So here are a few example callback class declarations: package MyApp::Callback; use base qw(Params::Callback); __PACKAGE__->register_subclass( class_key => 'MyCBHandler' ); In this declaration C will create a C class method returning "MyCBHandler" in the MyApp::CallbackHandler class. package MyApp::AnotherCallback; use base qw(MyApp::Callback); __PACKAGE__->register_subclass; use constant CLASS_KEY => 'AnotherCallback'; In this declaration, we've created an explicit C class method (using the handy C syntax, so that C doesn't have to. package MyApp::Callback::Foo; use base qw(Params::Callback); __PACKAGE__->register_subclass; And in this callback class declaration, we've specified neither a C parameter to C, nor created a C class method. This causes C to create the C class method returning the name of the class itself, i.e., "MyApp::FooHandler". Thus any parameter-triggered callbacks in this class can be triggered by using the class name in the trigger key: my $params = { "MyApp::Callback::Foo|take_action_cb" => 1 }; A second, optional parameter, C, may also be passed to C in order to set a default priority for all of the methods in the class (and for all the methods in subclasses that don't declare their own Cs): package MyApp::Callback; use base qw(Params::Callback); __PACKAGE__->register_subclass( class_key => 'MyCB', default_priority => 7 ); As with the C parameter, the C parameter creates a class method, C. If you'd rather, you can create this class method yourself; just be sure that its value is a valid priority -- that is, an integer between "0" and "9": package MyApp::Callback; use base qw(Params::Callback); use constant DEFAULT_PRIORITY => 7; __PACKAGE__->register_subclass( class_key => 'MyCB' ); Any callback class that does not specify a default priority via the C or by implementing a class method will simply inherit the priority returned by C<< Params::Callback->DEFAULT_PRIORITY >>, which is "5". B In a mod_perl environment, it's important that you C any and all Params::Callback subclasses I you C. This is to get around an issue with identifying the names of the callback methods in mod_perl. Read the comments in the source code if you're interested in learning more. =head2 Method Attributes These method attributes are required to create callback methods in Params::Callback subclasses. =head3 Callback sub take_action : Callback { my $self = shift; # Do stuff. } This attribute identifies a parameter-triggered callback method. The callback key is the same as the method name ("take_action" in this example). The priority for the callback may be set via an optional C parameter to the C attribute, like so: sub take_action : Callback( priority => 5 ) { my $self = shift; # Do stuff. } Otherwise, the priority will be that returned by C<< $self->DEFAULT_PRIORITY >>. B The priority set via the C parameter to the C attribute is not inherited by any subclasses that override the callback method. This may change in the future. =head3 PreCallback sub early_action : PreCallback { my $self = shift; # Do stuff. } This attribute identifies a method as a request callback that gets executed for every request I any parameter-triggered callbacks are executed . No parameters to C are currently supported. =head3 PostCallback sub late_action : PostCallback { my $self = shift; # Do stuff. } This attribute identifies a method as a request callback that gets executed for every request I any parameter-triggered callbacks are executed . No parameters to C are currently supported. =head1 TODO =over =item * Allow methods that override parent methods to inherit the parent method's priority? =back =head1 SEE ALSO L constructs Params::Callback objects and executes the appropriate callback functions and/or methods. It's worth a read. =head1 SUPPORT This module is stored in an open repository at the following address: L Patches against Params::CallbackRequest are welcome. Please send bug reports to . =head1 AUTHOR David E. Wheeler =head1 COPYRIGHT AND LICENSE Copyright 2003-2011 David E. Wheeler. Some Rights Reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Params-CallbackRequest-1.20/lib/Params/CallbackRequest.pm000444000765000024 12101511600551467 23073 0ustar00davidstaff000000000000package 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 any and all Params::Callback subclasses I you C. This is to get around an issue with identifying the names of the callback methods in mod_perl. Read the comments in the Params::Callback source code if you're interested in learning more. =head3 The Package Key The use of the package key is a convenience so that a system with many functional callbacks can use callbacks with the same keys but in different packages. The idea is that the package key will uniquely identify the module in which each callback subroutine is found, but it doesn't necessarily have to be so. Use the package key any way you wish, or not at all: my $cb_request = Params::CallbackRequest->new ( callbacks => [ { cb_key => 'save', cb => \&My::World::save } ] ); But note that if you don't specify the package key, you'll still need to provide one in the parameter hash passed to C. By default, that key is "DEFAULT". Such a callback parameter would then look like this: my $params = { "DEFAULT|save_cb" => 'Save World' }; If you don't like the "DEFAULT" package name, you can set an alternative default using the C parameter to C: my $cb_request = Params::CallbackRequest->new ( callbacks => [ { cb_key => 'save', cb => \&My::World::save } ], default_pkg_name => 'MyPkg' ); Then, of course, any callbacks without a specified package key of their own must then use the custom default: my $params = { "MyPkg|save_cb" => 'Save World' }; $cb_request->request($params); =head3 The Class Key The class key is essentially a synonym for the package key, but applies more directly to object-oriented callbacks. The difference is mainly that it corresponds to an actual class, and that all Params::Callback subclasses are I to have a class key; it's not optional as it is with functional callbacks. The class key may be declared in your Params::Callback subclass like so: package MyApp::CallbackHandler; use base qw(Params::Callback); __PACKAGE__->register_subclass( class_key => 'MyCBHandler' ); The class key can also be declared by implementing a C subroutine, like so: package MyApp::CallbackHandler; use base qw(Params::Callback); __PACKAGE__->register_subclass; use constant CLASS_KEY => 'MyCBHandler'; If no class key is explicitly defined, Params::Callback will use the subclass name, instead. In any event, the C method B be called to register the subclass with Params::Callback. See the L documentation for complete details. =head3 Priority Sometimes one callback is more important than another. For example, you might rely on the execution of one callback to set up variables needed by another. Since you can't rely on the order in which callbacks are executed (the parameters are passed via a hash, and the processing of a hash is, of course, unordered), you need a method of ensuring that the setup callback executes first. In such a case, you can set a higher priority level for the setup callback than for callbacks that depend on it. For functional callbacks, you can do it like this: my $cb_request = Params::CallbackRequest->new ( callbacks => [ { cb_key => 'setup', priority => 3, cb => \&setup }, { cb_key => 'save', cb => \&save } ] ); For object-oriented callbacks, you can define the priority right in the callback method declaration: sub setup : Callback( priority => 3 ) { my $self = shift; # ... } sub save : Callback { my $self = shift; # ... } In these examples, the "setup" callback has been configured with a priority level of "3". This ensures that it will always execute before the "save" callback, which has the default priority of "5". Obviously, this is true regardless of the order of the fields in the hash: my $params = { "DEFAULT|save_cb" => 'Save World', "DEFAULT|setup_cb" => 1 }; In this configuration, the "setup" callback will always execute first because of its higher priority. Although the "save" callback got the default priority of "5", this too can be customized to a different priority level via the C parameter to C for functional callbacks and the C to the class declaration for object-oriented callbacks. For example, this functional callback configuration: my $cb_request = Params::CallbackRequest->new ( callbacks => [ { cb_key => 'setup', priority => 3, cb => \&setup }, { cb_key => 'save', cb => \&save } ], default_priority => 2 ); Or this Params::Callback subclass declaration: package MyApp::CallbackHandler; use base qw(Params::Callback); __PACKAGE__->register_subclass( class_key => 'MyCBHandler', default_priority => 2 ); Will cause the "save" callback to always execute before the "setup" callback, since its priority level will default to "2". In addition, the priority level can be overridden via the parameter key itself by appending a priority level to the end of the key name. Hence, this example: my $params = { "DEFAULT|save_cb2" => 'Save World', "DEFAULT|setup_cb" => 1 }; Causes the "save" callback to execute before the "setup" callback by overriding the "save" callback's priority to level "2". Of course, any other parameter key that triggers the "save" callback without a priority override will still execute the "save" callback at its configured level. =head2 Request Callbacks Request callbacks come in two flavors: those that execute before the parameter-triggered callbacks, and those that execute after the parameter-triggered callbacks. Functional request callbacks may be specified via the C and C parameters to C, respectively: my $cb_request = Params::CallbackRequest->new ( pre_callbacks => [ \&translate, \&foobarate ], post_callbacks => [ \&escape, \&negate ] ); Object-oriented request callbacks may be declared via the C and C method attributes, like so: sub translate : PreCallback { ... } sub foobarate : PreCallback { ... } sub escape : PostCallback { ... } sub negate : PostCallback { ... } In these examples, the C and C subroutines or methods will execute (in that order) before any parameter-triggered callbacks are executed (none will be in these examples, since none are specified). Conversely, the C and C subroutines or methods will be executed (in that order) after all parameter-triggered callbacks have been executed. And regardless of what parameter-triggered callbacks may be triggered, the request callbacks will always be executed for I request (unless an exception is thrown by an earlier callback). Although they may be used for different purposes, the C and C functional callback code references expect the same argument as parameter-triggered functional callbacks: a Params::Callback object: sub foo { my $cb = shift; # Do your business here. } Similarly, object-oriented request callback methods will be passed an object of the class defined in the class key portion of the callback trigger -- either an object of the class in which the callback is defined, or an object of a subclass: sub foo : PostCallback { my $self = shift; # ... } Of course, the attributes of the Params::Callback or subclass object will be different than in parameter-triggered callbacks. For example, the C, C, and C attributes will naturally be undefined. It will, however, be the same instance of the object passed to all other functional callbacks -- or to all other class callbacks with the same class key -- in a single request. Like the parameter-triggered callbacks, request callbacks run under the nose of a custom exception handler, so if any of them Cs, an Params::Callback::Exception::Execution exception will be thrown. Use the C parameter to C if you don't like this. =head1 INTERFACE =head2 Parameters To The C Constructor Params::CallbackRequest supports a number of its own parameters to the C constructor (though none of them, sadly, trigger callbacks). The parameters to C are as follows: =over 4 =item C Parameter-triggered functional callbacks are configured via the C parameter. This parameter is an array reference of hash references, and each hash reference specifies a single callback. The supported keys in the callback specification hashes are: =over 4 =item C Required. A string that, when found in a properly-formatted parameter hash key, will trigger the execution of the callback. =item C Required. A reference to the Perl subroutine that will be executed when the C has been found in a parameter hash passed to C. Each code reference should expect a single argument: a Params::Callback object. The same instance of a Params::Callback object will be used for all functional callbacks in a single call to C. =item C Optional. A key to uniquely identify the package in which the callback subroutine is found. This parameter is useful in systems with many callbacks, where developers may wish to use the same C for different subroutines in different packages. The default package key may be set via the C parameter to C. =item C Optional. Indicates the level of priority of a callback. Some callbacks are more important than others, and should be executed before the others. Params::CallbackRequest supports priority levels ranging from "0" (highest priority) to "9" (lowest priority). The default priority for functional callbacks may be set via the C parameter. =back =item C This parameter accepts an array reference of code references that should be executed for I call to C I any parameter-triggered callbacks. They will be executed in the order in which they're listed in the array reference. Each code reference should expect a Params::Callback object as its sole argument. The same instance of a Params::Callback object will be used for all functional callbacks in a single call to C. Use pre-parameter-triggered request callbacks when you want to do something with the parameters submitted for every call to C, such as convert character sets. =item C This parameter accepts an array reference of code references that should be executed for I call to C I all parameter-triggered callbacks have been called. They will be executed in the order in which they're listed in the array reference. Each code reference should expect a Params::Callback object as its sole argument. The same instance of a Params::Callback object will be used for all functional callbacks in a single call to C. Use post-parameter-triggered request callbacks when you want to do something with the parameters submitted for every call to C, such as encode or escape their values for presentation. =item C An array reference listing the class keys of all of the Params::Callback subclasses containing callback methods that you want included in your Params::CallbackRequest object. Alternatively, the C parameter may simply be the word "ALL", in which case I Params::Callback subclasses will have their callback methods registered with your Params::CallbackRequest object. See the L documentation for details on creating callback classes and methods. B In a mod_perl environment, be sure to C I after you've Cd all of the Params::Callback subclasses you need or else you won't be able to use their callback methods. =item C The priority level at which functional callbacks will be executed. Does not apply to object-oriented callbacks. This value will be used in each hash reference passed via the C parameter to C that lacks a C key. You may specify a default priority level within the range of "0" (highest priority) to "9" (lowest priority). If not specified, it defaults to "5". =item C The default package key for functional callbacks. Does not apply to object-oriented callbacks. This value that will be used in each hash reference passed via the C parameter to C that lacks a C key. It can be any string that evaluates to a true value, and defaults to "DEFAULT" if not specified. =item C By default, Params::CallbackRequest will execute all callbacks triggered by parameter hash keys. However, in many situations it may be desirable to skip any callbacks that have no value for the callback field. One can do this by simply checking C<< $cbh->value >> in the callback, but if you need to disable the execution of all parameter-triggered callbacks when the callback parameter value is undefined or the null string (''), pass the C parameter with a true value. It is set to a false value by default. =item C By default, Params::CallbackRequest will clear out the contents of the hash accessed via the C method just before returning from a call to C. There may be some circumstances when it's desirable to allow the notes hash to persist beyond the duration of a a call to C. For example, a templating architecture may wish to keep the notes around for the duration of the execution of a template request. In such cases, pass a true value to the C parameter, and use the C method to manually clear out the notes hash at the appropriate point. =item C Params::CallbackRequest installs a custom exception handler during the execution of callbacks. This custom exception handler will simply rethrow any exception objects it comes across, but will throw a Params::Callback::Exception::Execution exception object if it is passed only a string value (such as is passed by C). But if you find that you're throwing your own exceptions in your callbacks, and want to handle them differently, pass the C parameter a code reference to do what you need. =back =head2 Instance Methods Params::CallbackRequest of course has several instance methods. I cover the most important, first. =head3 request $cb_request->request(\%params); # If you're in a mod_perl environment, pass in an Apache request object # to be passed to the Callback classes. $cb_request->request(\%params, apache_req => $r); # Or pass in argument to be passed to callback class constructors. $cb_request->request(\%params, @args); Executes the callbacks specified when the Params::CallbackRequest object was created. It takes a single required argument, a hash reference of parameters. Any subsequent arguments are passed to the constructor for each callback class for which callbacks will be executed. By default, the only extra parameter supported by the Params::Callback base class is an Apache request object, which can be passed via the C parameter. Returns the Params::CallbackRequest object on success, or the code passed to Params::Callback's C method if callback execution was aborted. A single call to C is referred to as a "callback request" (naturally!). First, all pre-request callbacks are executed. Then, any parameter-triggered callbacks triggered by the keys in the parameter hash reference passed as the sole argument are executed. And finally, all post-request callbacks are executed. C returns the Params::CallbackRequest object on successful completion of the request. Any callback that calls C on its Params::Callback object will prevent any other callbacks scheduled by the request to run subsequent to its execution from being executed (including post-request callbacks). Furthermore, any callback that Cs or throws an exception will of course also prevent any subsequent callbacks from executing, and in addition must also be caught by the caller or the whole process will terminate: eval { $cb_request->request(\%params) }; if (my $err = $@) { # Handle exception. } =head3 notes $cb_request->notes($key => $value); my $val = $cb_request->notes($key); my $notes = $cb_request->notes; The C method provides a place to store application data, giving developers a way to share data among multiple callbacks over the course of a call to C. Any data stored here persists for the duration of the request unless the C parameter to C has been passed a true value. In such cases, use C to manually clear the notes. Conceptually, C contains a hash of key-value pairs. C stores a new entry in this hash. C returns a previously stored value. C without any arguments returns a reference to the entire hash of key-value pairs. C is similar to the mod_perl method C<< $r->pnotes() >>. The main differences are that this C can be used in a non-mod_perl environment, and that its lifetime is tied to the lifetime of the call to C unless the C parameter is true. For the sake of convenience, a shortcut to C is provide to callback code via the L|Params::Callback/"notes"> method in Params::Callback. =head3 clear_notes $cb_request->clear_notes; Use this method to clear out the notes hash. Most useful when the C parameter to C has been set to at true value and you need to manage the clearing of notes yourself. This method is specifically designed for a templating environment, where it may be advantageous for the templating architecture to allow the notes to persist beyond the duration of a call to C, e.g., to keep them for the duration of a call to the templating architecture itself. See L for an example of this strategy. =head2 Accessor Methods The properties C and C have standard read-only accessor methods of the same name. For example: my $cb_request = Params::CallbackRequest->new; my $default_priority = $cb_request->default_priority; my $default_pkg_key = $cb_request->default_pkg_key; =head1 ACKNOWLEDGMENTS Garth Webb implemented the original callbacks in Bricolage, based on an idea he borrowed from Paul Lindner's work with Apache::ASP. My thanks to them both for planting this great idea! This implementation is however completely independent of previous implementations. =head1 SEE ALSO L objects get passed as the sole argument to all functional callbacks, and offer access to data relevant to the callback. Params::Callback also defines the object-oriented callback interface, making its documentation a must-read for anyone who wishes to create callback classes and methods. L uses this module to provide a callback architecture for HTML::Mason. =head1 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 COPYRIGHT AND LICENSE Copyright 2003-2011 David E. Wheeler. Some Rights Reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Params-CallbackRequest-1.20/lib/Params/CallbackRequest000755000765000024 011600551467 22340 5ustar00davidstaff000000000000Params-CallbackRequest-1.20/lib/Params/CallbackRequest/Exceptions.pm000444000765000024 1652211600551467 25202 0ustar00davidstaff000000000000package Params::CallbackRequest::Exceptions; use strict; use vars qw($VERSION); $VERSION = '1.20'; use Exception::Class ( 'Params::Callback::Exception' => { description => 'Params::Callback exception', alias => 'throw_cb' }, 'Params::Callback::Exception::InvalidKey' => { isa => 'Params::Callback::Exception', description => 'No callback found for callback key', alias => 'throw_bad_key', fields => [qw(callback_key)] }, 'Params::Callback::Exception::Execution' => { isa => 'Params::Callback::Exception', description => 'Error thrown by callback', alias => 'throw_cb_exec', fields => [qw(callback_key callback_error)] }, 'Params::Callback::Exception::Params' => { isa => 'Params::Callback::Exception', description => 'Invalid parameter', alias => 'throw_bad_params', fields => [qw(param)] }, 'Params::Callback::Exception::Abort' => { isa => 'Params::Callback::Exception', fields => [qw(aborted_value)], alias => 'throw_abort', description => 'a callback called abort()' }, ); sub import { my ($class, %args) = @_; my $caller = caller; if ($args{abbr}) { foreach my $name (@{$args{abbr}}) { no strict 'refs'; die "Unknown exception abbreviation '$name'" unless defined &{$name}; *{"${caller}::$name"} = \&{$name}; } } no strict 'refs'; *{"${caller}::isa_cb_exception"} = \&isa_cb_exception; *{"${caller}::rethrow_exception"} = \&rethrow_exception; } sub isa_cb_exception ($;$) { my ($err, $name) = @_; return unless defined $err; my $class = "Params::Callback::Exception"; $class .= "::$name" if $name; return UNIVERSAL::isa($err, $class); } sub rethrow_exception ($) { my $err = shift or return; $err->rethrow if UNIVERSAL::can($err, 'rethrow'); die $err if ref $err; Params::Callback::Exception->throw(error => $err); } 1; __END__ =head1 NAME Params::CallbackRequest::Exceptions - Parameter callback exception definitions =head1 SYNOPSIS use Params::CallbackRequest::Exceptions; Params::Callback::Exception::Execution->throw("Whoops!"); use Params::CallbackRequest::Exceptions abbr => [qw(throw_cb_exec)]; throw_cb_exec "Whoops!"; =head1 DESCRIPTION This module creates the exceptions used by Params::CallbackRequest and Params::Callback. The exceptions are subclasses of Exception::Class::Base, created by the interface defined by Exception::Class. =head1 INTERFACE =head2 Exported Functions This module exports two functions by default. =head3 C eval { something_that_dies() }; if (my $err = $@) { if (isa_cb_exception($err, 'Abort')) { print "All hands abandon ship!"; } elsif (isa_cb_exception($err)) { print "I recall an exceptional fault."; } else { print "No clue."; } } This function takes a single argument and returns true if it's a Params::Callback::Exception object. A second, optional argument can be used to identify a particular subclass of Params::Callback::Exception. =head3 C eval { something_that_dies() }; if (my $err = $@) { # Do something intelligent, and then... rethrow_exception($err); } This function takes an exception as its sole argument and rethrows it. If the argument is an object that C, such as any subclass of Exception::Class, then C will call its rethrow method. If not, but the argument is a reference, C will simply die with it. And finally, if the argument is not a reference at all, C will throw a new Params::Callback::Exception exception with the argument used as the exception error message. =head3 Abbreviated Exception Functions Each of the exception classes created by Params::CallbackRequest::Exceptions has a functional alias for its throw class method. These may be imported by passing an array reference of the names of the abbreviated functions to import via the C parameter: use Params::CallbackRequest::Exceptions abbr => [qw(throw_cb_exec)]; The names of the abbreviated functions are: =over 4 =item throw_cb Params::Callback::Exception =item throw_bad_key Params::Callback::Exception::InvalidKey =item throw_cb_exec Params::Callback::Exception::Execution =item throw_bad_params Params::Callback::Exception::Params =item throw_abort Params::Callback::Exception::Abort =back =head2 Exception Classes The exception classes created by Params::Callback::Exception are as follows: =head3 Params::Callback::Exception This is the base class for all Params::Callback exception classes. Its functional alias is C. =head3 Params::Callback::Exception::InvalidKey Params::CallbackRequest throws this exception when a callback key in the parameter hash passed to C has no corresponding callback. In addition to the attributes offered by Exception::Class::Base, this class also features the attribute C. Use the C accessor to see what callback key triggered the exception. Params::Callback::Exception::InvalidKey's functional alias is C. =head3 Params::Callback::Exception::Execution This is the exception thrown by Params::CallbackRequest's default exception handler when a callback subroutine or method dies. In addition to the attributes offered by Exception::Class::Base, this class also features the attributes C, which corresponds to the parameter key that triggered the callback, and C which is the error thrown by the callback subroutine or method. Params::Callback::Exception::Execution's functional alias is C. =head3 Params::Callback::Exception::Params This is the exception thrown when an invalid parameter is passed to Params::CallbackRequest's or Params::Callback's C constructors. Its functional alias is C. =head3 Params::Callback::Exception::Abort This is the exception thrown by Params::Callback's C method. functional alias is C. In addition to the attributes offered by Exception::Class::Base, this class also features the attribute C attribute. Use the C accessor to see what value was passed to C. Params::Callback::Exception::Abort's functional alias is C. =head1 SEE ALSO L is the base class for all callback classes. L sets up callbacks for execution. L defines the interface for the exception classes created here. =head1 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 COPYRIGHT AND LICENSE Copyright 2003-2011 David E. Wheeler. Some Rights Reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Params-CallbackRequest-1.20/t000755000765000024 011600551467 15545 5ustar00davidstaff000000000000Params-CallbackRequest-1.20/t/01basic.t000444000765000024 3200711600551467 17333 0ustar00davidstaff000000000000#!perl -w use strict; use Test::More tests => 73; BEGIN { use_ok('Params::CallbackRequest') } my $key = 'myCallbackTester'; my $cbs = []; ############################################################################## # Set up callback functions. ############################################################################## # Simple callback. sub simple { my $cb = shift; isa_ok( $cb, 'Params::Callback' ); isa_ok( $cb->cb_request, 'Params::CallbackRequest' ); my $params = $cb->params; $params->{result} = 'Success'; } push @$cbs, { pkg_key => $key, cb_key => 'simple', cb => \&simple }; ############################################################################## # Array value callback. sub array_count { my $cb = shift; isa_ok( $cb, 'Params::Callback' ); my $params = $cb->params; my $val = $cb->value; # For some reason, if I don't eval this, then the code in the rest of # the function doesn't run! eval { isa_ok( $val, 'ARRAY' ) }; $params->{result} = scalar @$val; } push @$cbs, { pkg_key => $key, cb_key => 'array_count', cb => \&array_count }; ############################################################################## # Hash value callback. sub hash_check { my $cb = shift; isa_ok( $cb, 'Params::Callback'); my $params = $cb->params; my $val = $cb->value; # For some reason, if I don't eval this, then the code in the rest of # the function doesn't run! eval { isa_ok( $val, 'HASH' ) }; $params->{result} = "$val" } push @$cbs, { pkg_key => $key, cb_key => 'hash_check', cb => \&hash_check }; ############################################################################## # Code value callback. sub code_check { my $cb = shift; isa_ok( $cb, 'Params::Callback'); my $params = $cb->params; my $val = $cb->value; # For some reason, if I don't eval this, then the code in the rest of # the function doesn't run! eval { isa_ok( $val, 'CODE' ) }; $params->{result} = $val->(); } push @$cbs, { pkg_key => $key, cb_key => 'code_check', cb => \&code_check }; ############################################################################## # Count the number of times the callback executes. sub count { my $cb = shift; isa_ok( $cb, 'Params::Callback'); my $params = $cb->params; $params->{result}++; } push @$cbs, { pkg_key => $key, cb_key => 'count', cb => \&count }; ############################################################################## # Abort callbacks. sub test_abort { my $cb = shift; isa_ok( $cb, 'Params::Callback'); my $params = $cb->params; $params->{result} = 'aborted'; $cb->abort(1); } push @$cbs, { pkg_key => $key, cb_key => 'test_abort', cb => \&test_abort }; ############################################################################## # Check the aborted value. sub test_aborted { my $cb = shift; isa_ok( $cb, 'Params::Callback'); my $params = $cb->params; my $val = $cb->value; eval { $cb->abort(1) } if $val; $params->{result} = $cb->aborted($@) ? 'yes' : 'no'; } push @$cbs, { pkg_key => $key, cb_key => 'test_aborted', cb => \&test_aborted }; ############################################################################## # We'll use this callback just to grab the value of the "submit" parameter. sub submit { my $cb = shift; isa_ok( $cb, 'Params::Callback'); my $params = $cb->params; $params->{result} = $params->{submit}; } push @$cbs, { pkg_key => $key, cb_key => 'submit', cb => \&submit }; ############################################################################## # We'll use these callbacks to test notes(). sub add_note { my $cb = shift; $cb->notes($cb->value, $cb->params->{note}); } sub get_note { my $cb = shift; $cb->params->{result} = $cb->notes($cb->value); } sub list_notes { my $cb = shift; my $params = $cb->params; my $notes = $cb->notes; for my $k (sort keys %$notes) { $params->{result} .= "$k => $notes->{$k}\n"; } } sub clear { my $cb = shift; $cb->cb_request->clear_notes; } push @$cbs, { pkg_key => $key, cb_key => 'add_note', cb => \&add_note }, { pkg_key => $key, cb_key => 'get_note', cb => \&get_note }, { pkg_key => $key, cb_key => 'list_notes', cb => \&list_notes }, { pkg_key => $key, cb_key => 'clear', cb => \&clear }; ############################################################################## # We'll use this callback to change the result to uppercase. sub upper { my $cb = shift; my $params = $cb->params; if ($params->{do_upper}) { isa_ok( $cb, 'Params::Callback'); $params->{result} = uc $params->{result}; } } ############################################################################## # We'll use this callback to flip the characters of the "submit" parameter. # The value of the "submit" parameter won't be "racecar!" sub flip { my $cb = shift; my $params = $cb->params; if ($params->{do_flip}) { isa_ok( $cb, 'Params::Callback'); $params->{submit} = reverse $params->{submit}; } } ############################################################################## # Construct the CallbackRequest object. ############################################################################## ok( my $cb_request = Params::CallbackRequest->new ( callbacks => $cbs, post_callbacks => [\&upper], pre_callbacks => [\&flip] ), "Construct CBExec object" ); isa_ok($cb_request, 'Params::CallbackRequest' ); # Check its accessor methods. is( $cb_request->default_priority, 5, "Check default priority" ); is ( $cb_request->default_pkg_key, 'DEFAULT', "Check default package name" ); ############################################################################## # Test the callbacks themselves. ############################################################################## # Try a Simple callback. my %params = ( "$key|simple_cb" => 1 ); ok( $cb_request->request(\%params), "Execute simple callback" ); is( $params{result}, 'Success', "Check simple result" ); ############################################################################## # Test an array reference value. %params = ( "$key|array_count_cb" => [1,2,3,4,5] ); ok( $cb_request->request(\%params), "Execute array count callback" ); is( $params{result}, 5, "Check array count result" ); ############################################################################## # Test a hash reference. %params = ( "$key|hash_check_cb" => { one => 1 } ); ok( $cb_request->request(\%params), "Execute hash check callback" ); is( $params{result}, $params{"$key|hash_check_cb"}, "Check hash check result" ); ############################################################################## # Test a code reference. %params = ( "$key|code_check_cb" => sub { 'yes!' } ); ok( $cb_request->request(\%params), "Execute code callback" ); is( $params{result}, 'yes!', "Check code result" ); ############################################################################## # Make sure that two similar callbacks set up like image callbacks are getting # properly executed. %params = ( "$key|simple_cb.x" => 18, "$key|simple_cb.y" => 24 ); ok( $cb_request->request(\%params), "Execute image button callback" ); is( $params{result}, 'Success', "Check image button result" ); ############################################################################## # Make sure that the image button parameters cause the callback to be called # only once. %params = ( "$key|count_cb.x" => 18, "$key|count_cb.y" => 24 ); ok( $cb_request->request(\%params), "Execute image button count callback" ); is( $params{result}, 1, "Check image button count result" ); ############################################################################## # Just like the above, but make sure that different priorities execute # at different times. %params = ( "$key|count_cb1.x" => 18, "$key|count_cb1.y" => 24, "$key|count_cb2.x" => 18, "$key|count_cb2.y" => 24 ); ok( $cb_request->request(\%params), "Execute image button priority callback" ); is( $params{result}, 2, "Check image button priority result" ); ############################################################################## # Test the abort functionality. The abort callback's higher priority should # cause it to prevent simple from being called. %params = ( "$key|simple_cb" => 1, "$key|test_abort_cb0" => 1 ); is( $cb_request->request(\%params), 1, "Execute abort callback" ); is( $params{result}, 'aborted', "Check abort result" ); ############################################################################## # Test the aborted method. %params = ( "$key|test_aborted_cb" => 1 ); is( $cb_request->request(\%params), $cb_request, "Execute aborted callback" ); is( $params{result}, 'yes', "Check aborted result" ); ############################################################################## # Test notes. my $note_key = 'myNote'; my $note = 'Test note'; %params = ("$key|add_note_cb1" => $note_key, # Executes first. note => $note, "$key|get_note_cb" => $note_key); is( $cb_request->request(\%params), $cb_request, "Add and get note" ); is( $params{result}, $note, "Check note result" ); # Make sure the note isn't available on the next request. %params = ( "$key|get_note_cb" => $note_key ); is( $cb_request->request(\%params), $cb_request, "Get no note" ); is( $params{result}, undef, "Check no note result" ); # Tell the callback request object to leave the notes and try again. ok( $cb_request = Params::CallbackRequest->new ( callbacks => $cbs, leave_notes => 1, post_callbacks => [\&upper], pre_callbacks => [\&flip] ), "Construct a new CBExec object" ); %params = ("$key|add_note_cb1" => $note_key, # Executes first. note => $note, "$key|get_note_cb" => $note_key); is( $cb_request->request(\%params), $cb_request, "Add and get note again" ); is( $params{result}, $note, "Check note result" ); # Make sure the note isn't available on the next request. %params = ( "$key|get_note_cb" => $note_key ); is( $cb_request->request(\%params), $cb_request, "Get persistent note" ); is( $params{result}, $note, "Check presistent note result" ); # Add another note. %params = ("$key|add_note_cb1" => $note_key . 1, # Executes first. note => $note . 1, "$key|list_notes_cb" => 1); is( $cb_request->request(\%params), $cb_request, "Add another note" ); is( $params{result}, "$note_key => $note\n${note_key}1 => ${note}1\n", "Check multiple note result" ); # And finally, clear the notes out. %params = ( "$key|clear_cb1" => 1, # Executes first. "$key|list_notes_cb" => 1); is( $cb_request->request(\%params), $cb_request, "Clear notes" ); is( $params{result}, undef, "Check cleared note result" ); ############################################################################## # Test the pre-execution callbacks. my $string = 'yowza'; %params = ( "$key|submit_cb" => 1, submit => $string, do_flip => 1 ); ok( $cb_request->request(\%params), "Execute pre callback" ); is( $params{result}, reverse($string), "Check pre result" ); ############################################################################## # Test the post-execution callbacks. %params = ( "$key|simple_cb" => 1, do_upper => 1 ); ok( $cb_request->request(\%params), "Execute post callback" ); is( $params{result}, 'SUCCESS', "Check post result" ); ############################################################################## # Now make sure that a callback with a value executes. ok( my $new_cb_request = Params::CallbackRequest->new( callbacks => $cbs, ignore_nulls => 1), "Create new CBExec that ignores nulls" ); %params = ( "$key|simple_cb" => 1); ok( $new_cb_request->request(\%params), "Execute simple callback" ); is( $params{result}, 'Success', "Check simple result" ); # And try it with a null value. %params = ( "$key|simple_cb" => ''); ok( $new_cb_request->request(\%params), "Execute null simple callback" ); is( $params{result}, undef, "Check null simple result" ); # And with undef. %params = ( "$key|simple_cb" => undef); ok( $new_cb_request->request(\%params), "Execute undef simple callback" ); is( $params{result}, undef, "Check undef simple result" ); # But 0 should succeed. %params = ( "$key|simple_cb" => 0); ok( $new_cb_request->request(\%params), "Execute 0 simple callback" ); is( $params{result}, 'Success', "Check 0 simple result" ); 1; __END__ Params-CallbackRequest-1.20/t/02priority.t000444000765000024 574011600551467 20120 0ustar00davidstaff000000000000#!perl -w use strict; use Test::More tests => 30; BEGIN { use_ok('Params::CallbackRequest') } my $key = 'myCallbackTester'; my $cbs = []; ############################################################################## # Set up callback functions. ############################################################################## # Priority callback. sub priority { my $cb = shift; isa_ok( $cb, 'Params::Callback'); my $params = $cb->params; my $val = $cb->value; $val = $cb->priority if $val eq 'def'; $params->{result} .= " $val"; } sub chk_priority { my $cb = shift; isa_ok( $cb, 'Params::Callback'); my $val = $cb->value; is( $cb->priority, $val, "Check priority value '$val'" ); } sub def_priority { my $cb = shift; isa_ok( $cb, 'Params::Callback'); is( $cb->priority, 5, "Check default priority" ); } push @$cbs, { pkg_key => $key, cb_key => 'priority', cb => \&priority, priority => 6 }, { pkg_key => $key, cb_key => 'chk_priority', cb => \&chk_priority, priority => 2 }, { pkg_key => $key, cb_key => 'def_priority', cb => \&def_priority, }; ############################################################################## # Construct the CallbackRequest object. ############################################################################## ok( my $cb_request = Params::CallbackRequest->new( callbacks => $cbs), "Construct CBExec object" ); isa_ok($cb_request, 'Params::CallbackRequest' ); ############################################################################## # Test the callbacks themselves. ############################################################################## # Test the priority ordering. my %params = ( "$key|priority_cb0" => 0, "$key|priority_cb2" => 2, "$key|priority_cb9" => 9, "$key|priority_cb7" => 7, "$key|priority_cb1" => 1, "$key|priority_cb4" => 4, "$key|priority_cb" => 'def' ); ok( $cb_request->request(\%params), "Execute priority callback" ); is( $params{result}, " 0 1 2 4 6 7 9", "Check priority result" ); ############################################################################## # Test the default priority. %params = ( "$key|def_priority_cb" => 1); ok( $cb_request->request(\%params), "Execute default priority callback" ); ############################################################################## # Check various priority values. %params = ( "$key|chk_priority_cb0" => 0, "$key|chk_priority_cb2" => 2, "$key|chk_priority_cb9" => 9, "$key|chk_priority_cb7" => 7, "$key|chk_priority_cb1" => 1, "$key|chk_priority_cb4" => 4, "$key|chk_priority_cb" => 2 ); ok( $cb_request->request(\%params), "Execute priority values" ); 1; __END__ Params-CallbackRequest-1.20/t/03keys.t000444000765000024 1014011600551467 17221 0ustar00davidstaff000000000000#!perl -w use strict; use Test::More tests => 15; BEGIN { use_ok('Params::CallbackRequest') } my $key = 'myCallbackTester'; my $cbs = []; ############################################################################## # Set up callback functions. ############################################################################## # Callback to test the value of the package key attribute. sub test_pkg_key { my $cb = shift; my $params = $cb->params; $params->{result} .= $cb->pkg_key; } push @$cbs, { pkg_key => $key, cb_key => 'test_pkg_key', cb => \&test_pkg_key }, { pkg_key => $key . '_more', cb_key => 'test_pkg_key', cb => \&test_pkg_key }; ############################################################################## # Callback to test the value returned by the class_key method. sub test_class_key { my $cb = shift; my $params = $cb->params; $params->{result} .= $cb->class_key; } push @$cbs, { pkg_key => $key, cb_key => 'test_class_key', cb => \&test_class_key }, { pkg_key => $key. '_more', cb_key => 'test_class_key', cb => \&test_class_key }; ############################################################################## # Callback to test the value of the trigger key attribute. sub test_trigger_key { my $cb = shift; my $params = $cb->params; $params->{result} .= $cb->trigger_key; } push @$cbs, { pkg_key => $key, cb_key => 'test_trigger_key', cb => \&test_trigger_key }, { pkg_key => $key . '_more', cb_key => 'test_trigger_key', cb => \&test_trigger_key }; ############################################################################## # Construct the CallbackRequest object. ############################################################################## ok( my $cb_request = Params::CallbackRequest->new( callbacks => $cbs), "Construct CBExec object" ); isa_ok($cb_request, 'Params::CallbackRequest' ); ############################################################################## # Test the callbacks themselves. ############################################################################## # Test the package key. my %params = ( "$key|test_pkg_key_cb" => 1 ); ok( $cb_request->request(\%params), "Execute test_pkg_key callback" ); is( $params{result}, $key, "Check pkg key" ); # And multiple package keys. %params = ( "$key|test_pkg_key_cb1" => 1, "$key\_more|test_pkg_key_cb2" => 1, "$key|test_pkg_key_cb3" => 1, ); ok( $cb_request->request(\%params), "Execute test_pkg_key callback again" ); is( $params{result}, "$key$key\_more$key", "Check pkg key again" ); ############################################################################## # Test the class key. %params = ( "$key|test_class_key_cb" => 1 ); ok( $cb_request->request(\%params), "Execute test_class_key callback" ); is( $params{result}, $key, "Check class key" ); # And multiple class keys. %params = ( "$key|test_class_key_cb1" => 1, "$key\_more|test_class_key_cb2" => 1, "$key|test_class_key_cb3" => 1, ); ok( $cb_request->request(\%params), "Execute test_class_key callback again" ); is( $params{result}, "$key$key\_more$key", "Check class key again" ); ############################################################################## # Test the trigger key. %params = ( "$key|test_trigger_key_cb" => 1 ); ok( $cb_request->request(\%params), "Execute test_trigger_key callback" ); is( $params{result}, "$key|test_trigger_key_cb", "Check trigger key" ); # And multiple trigger keys. %params = ( "$key|test_trigger_key_cb1" => 1, "$key\_more|test_trigger_key_cb2" => 1, "$key|test_trigger_key_cb3" => 1,); ok( $cb_request->request(\%params), "Execute test_trigger_key callbac again" ); is( $params{result}, "$key|test_trigger_key_cb1$key\_more|" . "test_trigger_key_cb2$key|test_trigger_key_cb3", "Check trigger key again" ); 1; __END__ Params-CallbackRequest-1.20/t/04errors.t000444000765000024 1560611600551467 17577 0ustar00davidstaff000000000000#!perl -w use strict; use Test::More tests => 51; BEGIN { use_ok('Params::CallbackRequest') } my $key = 'myCallbackTester'; sub mydie { die "Ouch!" } sub myfault { die bless {}, 'TestException' } my %cbs = ( pkg_key => $key, cb_key => 'mydie', cb => \&mydie ); my %fault_cb = ( pkg_key => $key, cb_key => 'myfault', cb => \&myfault ); ############################################################################## # Set up callback functions. ############################################################################## # Check that we get a warning for when there are no callbacks. { local $SIG{__WARN__} = sub { like( $_[0], qr/You didn't specify any callbacks/, "Check warning") }; ok( Params::CallbackRequest->new, "Construct CBExec object without CBs" ); } ############################################################################## # Try to construct a CBE object with a bad callback key. my %c = %cbs; $c{cb_key} = ''; eval {Params::CallbackRequest->new(callbacks => [\%c]) }; ok( my $err = $@, "Catch bad cb_key exception" ); isa_ok($err, 'Params::Callback::Exception' ); isa_ok($err, 'Params::Callback::Exception::Params' ); like( $err->error, qr/Missing or invalid callback key/, "Check bad cb_key error message" ); ############################################################################## # Try to construct a CBE object with a bad priority. %c = %cbs; $c{priority} = 'foo'; eval {Params::CallbackRequest->new(callbacks => [\%c]) }; ok( $err = $@, "Catch bad priority exception" ); isa_ok($err, 'Params::Callback::Exception' ); isa_ok($err, 'Params::Callback::Exception::Params' ); like( $err->error, qr/Not a valid priority: 'foo'/, "Check bad priority error message" ); ############################################################################## # Test a bad code ref. my $msg = "Callback for package key 'myCallbackTester' and callback key " . "'coderef' not a code reference"; %c = %cbs; $c{cb_key} = 'coderef'; $c{cb} = 'bogus'; # Ooops. eval {Params::CallbackRequest->new(callbacks => [\%c]) }; ok( $err = $@, "Catch bad code ref exception" ); isa_ok($err, 'Params::Callback::Exception' ); isa_ok($err, 'Params::Callback::Exception::Params' ); like( $err->error, qr/$msg/, "Check bad code ref error message" ); ############################################################################## # Test for a used key. %c = my %b = %cbs; $c{cb_key} = $b{cb_key} = 'bar'; # Ooops. eval {Params::CallbackRequest->new(callbacks => [\%c, \%b]) }; ok( $err = $@, "Catch used key exception" ); isa_ok($err, 'Params::Callback::Exception' ); isa_ok($err, 'Params::Callback::Exception::Params' ); like( $err->error, qr/Callback key 'bar' already used by package key '$key'/, "Check used key error message" ); ############################################################################## # Test a bad request code ref. eval {Params::CallbackRequest->new(pre_callbacks => ['foo']) }; ok( $err = $@, "Catch bad request code ref exception" ); isa_ok($err, 'Params::Callback::Exception' ); isa_ok($err, 'Params::Callback::Exception::Params' ); like( $err->error, qr/Request pre callback not a code reference/, 'Check bad request code ref exception' ); ############################################################################## # Make sure that Params::Validate is using our exceptions. $msg = 'The following parameter was passed in the call to ' . 'Params::CallbackRequest::new but was not listed in the validation options: ' . 'feh'; eval {Params::CallbackRequest->new(feh => 1) }; ok( $err = $@, "Catch bad parameter exception" ); isa_ok($err, 'Params::Callback::Exception' ); isa_ok($err, 'Params::Callback::Exception::Params' ); like( $err->error, qr/$msg/, 'Check bad parameter exception' ); ############################################################################## # Construct one to be used for exceptions during the execution of callbacks. ############################################################################## ok( my $cb_request = Params::CallbackRequest->new( callbacks => [\%cbs, \%fault_cb]), "Construct CBExec object" ); isa_ok($cb_request, 'Params::CallbackRequest' ); ############################################################################## # Send a bad argument to execute(). eval { $cb_request->request('foo') }; # oops! ok( $err = $@, "Catch bad argument exception" ); isa_ok($err, 'Params::Callback::Exception' ); isa_ok($err, 'Params::Callback::Exception::Params' ); like( $err->error, qr/Parameter 'foo' is not a hash reference/, 'Check bad argument exception' ); ############################################################################## # Test the callbacks themselves. ############################################################################## # Make sure an exception get thrown for a non-existant package. my %params = ( 'NoSuchLuck|foo_cb' => 1 ); eval { $cb_request->request(\%params) }; ok( $err = $@, "Catch bad package exception" ); isa_ok($err, 'Params::Callback::Exception' ); isa_ok($err, 'Params::Callback::Exception::InvalidKey' ); like( $err->error, qr/No such callback package 'NoSuchLuck'/, "Check bad package message" ); ############################################################################## # Make sure an exception get thrown for a non-existant callback. %params = ( "$key|foo_cb" => 1 ); eval { $cb_request->request(\%params) }; ok( $err = $@, "Catch missing callback exception" ); isa_ok($err, 'Params::Callback::Exception' ); isa_ok($err, 'Params::Callback::Exception::InvalidKey' ); like( $err->error, qr/No callback found for callback key '$key|foo_cb'/, "Check missing callback message" ); ############################################################################## # Now die from within our callback function. %params = ( "$key|mydie_cb" => 1 ); eval { $cb_request->request(\%params) }; ok( $err = $@, "Catch our exception" ); isa_ok($err, 'Params::Callback::Exception' ); isa_ok($err, 'Params::Callback::Exception::Execution' ); like( $err->error, qr/^Error thrown by callback: Ouch! at/, "Check our mydie message" ); like( $err->callback_error, qr/^Ouch! at/, "Check our die message" ); ############################################################################## # Now throw our own exception. %params = ( "$key|myfault_cb" => 1 ); eval { $cb_request->request(\%params) }; ok( $err = $@, "Catch our exception" ); isa_ok($err, 'TestException' ); ############################################################################## # Now test exception_handler. %params = ( "$key|mydie_cb" => 1 ); ok( $cb_request = Params::CallbackRequest->new ( callbacks => [\%cbs], exception_handler => sub { like( $_[0], qr/^Ouch! at/, "Custom check our die message" ); }), "Construct CBExec object with custom exception handler" ); ok( $cb_request->request(\%params), "Execute callbacks with exception handler" ); 1; __END__ Params-CallbackRequest-1.20/t/05object.t000444000765000024 3014211600551467 17522 0ustar00davidstaff000000000000#!perl -w use strict; use Test::More; my $base_key = 'OOTester'; my $err_msg = "He's dead, Jim"; ############################################################################## # Figure out if the current configuration can handle OO callbacks. BEGIN { plan skip_all => 'Object-oriented callbacks require Perl 5.6.0 or later' if $] < 5.006; plan skip_all => 'Attribute::Handlers and Class::ISA required for' . ' object-oriented callbacks' unless eval { require Attribute::Handlers } and eval { require Class::ISA }; plan tests => 181; } ############################################################################## # Set up the callback class. ############################################################################## package Params::Callback::TestObjects; use strict; use base 'Params::Callback'; __PACKAGE__->register_subclass( class_key => $base_key); use Params::CallbackRequest::Exceptions abbr => [qw(throw_cb_exec)]; sub simple : Callback { my $self = shift; main::isa_ok($self, 'Params::Callback'); main::isa_ok($self, __PACKAGE__); my $params = $self->params; $params->{result} = 'Simple Success'; } sub complete : Callback(priority => 3) { my $self = shift; main::isa_ok($self, 'Params::Callback'); main::isa_ok($self, __PACKAGE__); main::is($self->priority, 3, "Check priority is '3'" ); my $params = $self->params; $params->{result} = 'Complete Success'; } sub inherit : Callback { my $self = shift; my $params = $self->params; $params->{result} = UNIVERSAL::isa($self, 'Params::Callback') ? 'Yes' : 'No'; } sub highest : Callback(priority => 0) { my $self = shift; main::is( $self->priority, 0, "Check priority is '0'" ); } sub upperit : PreCallback { my $self = shift; my $params = $self->params; $params->{result} = uc $params->{result} if $params->{do_upper}; } sub pre_post : Callback { my $self = shift; my $params = $self->params; $params->{chk_post} = 1; } sub lowerit : PostCallback { my $self = shift; my $params = $self->params; $params->{result} = lc $params->{result} if $params->{do_lower}; } sub class : Callback { my $self = shift; main::isa_ok( $self, __PACKAGE__); main::isa_ok( $self, $self->value); } sub chk_priority : Callback { my $self = shift; my $priority = $self->priority; my $val = $self->value; $val = 5 if $val eq 'def'; main::is($priority, $val, "Check for priority '$val'" ); my $params = $self->params; $params->{result} .= " " . $priority; } sub test_abort : Callback { my $self = shift; $self->abort(1); } sub test_aborted : Callback { my $self = shift; my $params = $self->params; my $val = $self->value; eval { $self->abort(1) } if $val; $params->{result} = $self->aborted($@) ? 'yes' : 'no'; } sub exception : Callback { my $self = shift; if ($self->value) { # Throw an exception object. throw_cb_exec $err_msg; } else { # Just die. die $err_msg; } } sub same_object : Callback { my $self = shift; my $params = $self->params; if ($self->value) { main::is($self, $params->{obj}, "Check for same object" ); } else { $params->{obj} = $self; } } 1; ############################################################################## # Now set up an emtpy callback subclass. ############################################################################## package Params::Callback::TestObjects::Empty; use strict; use base 'Params::Callback::TestObjects'; __PACKAGE__->register_subclass( class_key => $base_key . 'Empty'); 1; ############################################################################## # Now set up an a subclass that overrides a parent method. ############################################################################## package Params::Callback::TestObjects::Sub; use strict; use base 'Params::Callback::TestObjects'; __PACKAGE__->register_subclass( class_key => $base_key . 'Sub'); # Try a method with the same name as one in the parent, and which # calls the super method. sub inherit : Callback { my $self = shift; $self->SUPER::inherit; my $params = $self->params; $params->{result} .= ' and '; $params->{result} .= UNIVERSAL::isa($self, 'Params::Callback::TestObjects') ? 'Yes' : 'No'; } # Try a totally new method. sub subsimple : Callback { my $self = shift; my $params = $self->params; $params->{result} = 'Subsimple Success'; } # Try a totally new method. sub simple : Callback { my $self = shift; my $params = $self->params; $params->{result} = 'Oversimple Success'; } 1; ############################################################################## # Meanwhile, back at the ranch... ############################################################################## package main; # Keep track of who's who. my %classes = ( $base_key => 'Params::Callback::TestObjects', $base_key . 'Sub' => 'Params::Callback::TestObjects::Sub', $base_key . 'Empty' => 'Params::Callback::TestObjects::Empty'); use_ok('Params::CallbackRequest'); my $all = 'ALL'; for my $key ($base_key, $base_key . "Empty", $all) { # Create the CBExec object. my $cb_request; if ($key eq 'ALL') { # Load all of the callback classes. ok( $cb_request = Params::CallbackRequest->new( cb_classes => $key ), "Construct $key CBExec object" ); $key = $base_key; } else { # Load the base class and the subclass. ok( $cb_request = Params::CallbackRequest->new ( cb_classes => [$key, $base_key . 'Sub']), "Construct $key CBExec object" ); } ########################################################################## # Now make sure that the simple callback executes. my %params = ("$key|simple_cb" => 1); ok( $cb_request->request(\%params), "Execute simple callback" ); is( $params{result}, 'Simple Success', "Check simple result" ); ########################################################################## # And the "complete" callback. %params = ("$key|complete_cb" => 1); ok( $cb_request->request(\%params), "Execute complete callback" ); is( $params{result}, 'Complete Success', "Check complete result" ); ########################################################################## # Check the class name. %params = ("$key|inherit_cb" => 1); ok( $cb_request->request(\%params), "Execute inherit callback" ); is( $params{result}, 'Yes', "Check inherit result" ); ########################################################################## # Check class inheritance and SUPER method calls. %params = ($base_key . "Sub|inherit_cb" => 1); ok( $cb_request->request(\%params), "Execute SUPER inherit callback" ); is( $params{result}, 'Yes and Yes', "Check SUPER inherit result" ); ########################################################################## # Try pre-execution callbacks. %params = (do_upper => 1, result => 'upPer_mE'); ok( $cb_request->request(\%params), "Execute pre callback" ); is( $params{result}, 'UPPER_ME', "Check pre result" ); ########################################################################## # Try post-execution callbacks. %params = ("$key|simple_cb" => 1, do_lower => 1); ok( $cb_request->request(\%params), "Execute post callback" ); is( $params{result}, 'simple success', "Check post result" ); ########################################################################## # Try a method defined only in a subclass. %params = ($base_key . "Sub|subsimple_cb" => 1); ok( $cb_request->request(\%params), "Execute subsimple callback" ); is( $params{result}, 'Subsimple Success', "Check subsimple result" ); ########################################################################## # Try a method that overrides its parent but doesn't call its parent. %params = ($base_key . "Sub|simple_cb" => 1); ok( $cb_request->request(\%params), "Execute oversimple callback" ); is( $params{result}, 'Oversimple Success', "Check oversimple result" ); ########################################################################## # Try a method that overrides its parent but doesn't call its parent. %params = ($base_key . "Sub|simple_cb" => 1); ok( $cb_request->request(\%params), "Execute oversimple callback" ); is( $params{result}, 'Oversimple Success', "Check oversimple result" ); ########################################################################## # Check that the proper class ojbect is constructed. %params = ("$key|class_cb" => $classes{$key}); ok( $cb_request->request(\%params), "Execute class callback" ); ########################################################################## # Check priority execution order for multiple callbacks. %params = ("$key|chk_priority_cb0" => 0, "$key|chk_priority_cb2" => 2, "$key|chk_priority_cb9" => 9, "$key|chk_priority_cb7" => 7, "$key|chk_priority_cb1" => 1, "$key|chk_priority_cb4" => 4, "$key|chk_priority_cb" => 'def', ); ok( $cb_request->request(\%params), "Execute priority order callback" ); is($params{result}, " 0 1 2 4 5 7 9", "Check priority order result" ); ########################################################################## # Emulate the sumission of an button. %params = ("$key|simple_cb.x" => 18, "$key|simple_cb.y" => 22 ); ok( $cb_request->request(\%params), "Execute image callback" ); is( $params{result}, 'Simple Success', "Check single simple result" ); ########################################################################## # Make sure that if we abort, no more callbacks execute. %params = ("$key|test_abort_cb0" => 1, "$key|simple_cb" => 1, result => 'still here' ); is( $cb_request->request(\%params), 1, "Execute abort callback" ); is( $params{result}, 'still here', "Check abort result" ); ########################################################################## # Test aborted for a false value. %params = ("$key|test_aborted_cb" => 0 ); is( $cb_request->request(\%params), $cb_request, "Execute false aborted callback" ); is( $params{result}, 'no', "Check false aborted result" ); ########################################################################## # Test aborted for a true value. %params = ("$key|test_aborted_cb" => 1 ); ok( $cb_request->request(\%params), "Execute true aborted callback" ); is( $params{result}, 'yes', "Check true aborted result" ); ########################################################################## # Try throwing an execption. %params = ("$key|exception_cb" => 1 ); eval { $cb_request->request(\%params) }; ok( my $err = $@, "Catch $key exception" ); isa_ok($err, 'Params::Callback::Exception'); isa_ok($err, 'Params::Callback::Exception::Execution'); is( $err->error, $err_msg, "Check error message" ); ########################################################################## # Try die'ing. %params = ("$key|exception_cb" => 0 ); eval { $cb_request->request(\%params) }; ok( $err = $@, "Catch $key die" ); isa_ok($err, 'Params::Callback::Exception'); isa_ok($err, 'Params::Callback::Exception::Execution'); like( $err->error, qr/^Error thrown by callback: $err_msg/, "Check die error message" ); ########################################################################## # Make sure that the same object is called for multiple callbacks in the # same class. %params = ("$key|same_object_cb1" => 0, "$key|same_object_cb" => 1); ok( $cb_request->request(\%params), "Execute same object callback" ); ########################################################################## # Check priority 0 sticks. %params = ("$key|highest_cb" => undef); ok( $cb_request->request(\%params), "Execute check priority 0 attribute" ); } __END__ Params-CallbackRequest-1.20/t/06object_request.t000444000765000024 1627211600551467 21303 0ustar00davidstaff000000000000#!perl -w use strict; use Test::More; my $base_key; ############################################################################## # Figure out if the current configuration can handle OO callbacks. BEGIN { plan skip_all => 'Object-oriented callbacks require Perl 5.6.0 or later' if $] < 5.006; plan skip_all => 'Attribute::Handlers and Class::ISA required for' . ' object-oriented callbacks' unless eval { require Attribute::Handlers } and eval { require Class::ISA }; plan tests => 48; $base_key = 'OOTester'; } ############################################################################## # Set up the base callback class. ############################################################################## package Params::Callback::TestObjects; use strict; use base 'Params::Callback'; use constant CLASS_KEY => $base_key; use constant DEFAULT_PRIORITY => 3; __PACKAGE__->register_subclass; sub upperit : PreCallback { my $self = shift; my $params = $self->params; if ($params->{do_upper}) { main::isa_ok($self, 'Params::Callback'); main::isa_ok($self, __PACKAGE__); $params->{result} = uc $params->{result}; } } sub lowerit : PostCallback { my $self = shift; my $params = $self->params; if ($params->{do_lower}) { main::isa_ok($self, 'Params::Callback'); main::isa_ok($self, __PACKAGE__); $params->{result} = lc $params->{result}; } } sub pre_post : Callback { my $self = shift; main::isa_ok($self, 'Params::Callback'); main::isa_ok($self, __PACKAGE__); main::is($self->priority, 3, "Check default priority constant" ); my $params = $self->params; $params->{chk_post} = 1; } sub requestit : Callback { my $self = shift; my $value = $self->value; my $requester = $self->requester; main::is ref $requester || $requester, $value, "Request is '$value'"; } sub chk_post : PostCallback { my $self = shift; my $params = $self->params; if ($params->{chk_post}) { main::isa_ok($self, 'Params::Callback'); main::isa_ok($self, __PACKAGE__); # Most of the methods should return undefined values. my @res; foreach my $meth (qw(value pkg_key cb_key priority trigger_key)) { push @res, "$meth => '", $self->$meth, "'\n" if $self->$meth; } if (@res) { $params->{result} = "Oops, some of the accessors have values: @res"; } else { $params->{result} = 'Attributes okay'; } } } ############################################################################## # Now set up an a subclass that overrides pre and post execution callbacks, # and provides a couple of new ones, too. ############################################################################## package Params::Callback::TestObjects::Sub; use strict; use base 'Params::Callback::TestObjects'; use constant CLASS_KEY => $base_key . 'Sub'; __PACKAGE__->register_subclass; sub upperit : PreCallback { my $self = shift; $self->SUPER::upperit; my $params = $self->params; if ($params->{do_upper}) { main::isa_ok($self, 'Params::Callback'); main::isa_ok($self, 'Params::Callback::TestObjects'); main::isa_ok($self, __PACKAGE__); $params->{result} .= ' Overridden'; } } sub lowerit : PostCallback { my $self = shift; $self->SUPER::lowerit; my $params = $self->params; if ($params->{do_lower}) { main::isa_ok($self, 'Params::Callback'); main::isa_ok($self, 'Params::Callback::TestObjects'); main::isa_ok($self, __PACKAGE__); $params->{result} .= ' Overridden'; } } # Try totally new methods. sub sub_pre : PreCallback { my $self = shift; my $params = $self->params; if ($params->{do_lower} or $params->{do_upper}) { main::isa_ok($self, 'Params::Callback'); main::isa_ok($self, 'Params::Callback::TestObjects'); main::isa_ok($self, __PACKAGE__); $params->{result} .= ' PreCallback'; } } sub sub_post : PostCallback { my $self = shift; my $params = $self->params; if ($params->{do_lower} or $params->{do_upper}) { main::isa_ok($self, 'Params::Callback'); main::isa_ok($self, 'Params::Callback::TestObjects'); main::isa_ok($self, __PACKAGE__); $params->{result} .= ' PostCallback'; } } 1; ############################################################################## # Move along, little doggies! ############################################################################## package main; use strict; use_ok( 'Params::CallbackRequest' ); ############################################################################## # Make sure that the base pre and post callbacks work properly. Start with # post. ok( my $cb_request = Params::CallbackRequest->new(cb_classes => [$base_key]), "Construct base callback CBExec" ); ############################################################################## # Start with post. my %params = (do_lower => 1, result => 'LOWER ME, BABY!'); ok( $cb_request->request(\%params), "Execute post callback" ); is( $params{result}, 'lower me, baby!', "Check post callback result" ); ############################################################################## # Now check pre. %params = (do_upper => 1, result => 'taKe mE uP!'); ok( $cb_request->request(\%params), "Execute pre callback" ); is( $params{result}, 'TAKE ME UP!', "Check pre callback result" ); ############################################################################## # Make sure that pre and post execution callback inheritance works properly. ok( $cb_request = Params::CallbackRequest->new (cb_classes => [$base_key . 'Sub']), "Construct subclasseed callback CBExec" ); ############################################################################## # Post first. %params = (do_lower => 1, result => 'LOWER ME'); ok( $cb_request->request(\%params), "Test subclassed post callback" ); is( $params{result}, 'lower me precallback Overridden PostCallback', "Check subclassed post callback result" ); ############################################################################## # Now check pre. %params = (do_upper => 1, result => 'taKe mE uP aGain!'); ok( $cb_request->request(\%params), "Execute subclassed pre callback" ); is( $params{result}, 'TAKE ME UP AGAIN! Overridden PreCallback PostCallback', "Check subclassed pre callback result" ); ############################################################################## # Check that no of the unneeded attributes are populated during request # callbacks. %params = ("$base_key|pre_post_cb" => 1); ok( $cb_request->request(\%params), "Execute attribute check callback" ); is( $params{result}, 'Attributes okay', "Check attribute check result" ); ############################################################################## # Check that requester is properly passed. %params = ("$base_key|requestit_cb" => 'foo'); ok( $cb_request->request(\%params, requester => 'foo'), "Execute request callback" ); %params = ("$base_key|requestit_cb" => ref $cb_request ); ok( $cb_request->request(\%params, requester => $cb_request ), "Execute request as object callback" ); 1; __END__ Params-CallbackRequest-1.20/t/07combined.t000444000765000024 1020511600551467 20034 0ustar00davidstaff000000000000#!perl -w use strict; use Test::More; my $base_key = 'OOTester'; ############################################################################## # Figure out if the current configuration can handle OO callbacks. BEGIN { plan skip_all => 'Object-oriented callbacks require Perl 5.6.0 or later' if $] < 5.006; plan skip_all => 'Attribute::Handlers and Class::ISA required for' . ' object-oriented callbacks' unless eval { require Attribute::Handlers } and eval { require Class::ISA }; plan tests => 20; } ############################################################################## # Set up the callback class. ############################################################################## package Params::Callback::TestObjects; use strict; use base 'Params::Callback'; __PACKAGE__->register_subclass( class_key => $base_key); use Params::CallbackRequest::Exceptions abbr => [qw(throw_cb_exec)]; sub simple : Callback { my $self = shift; main::isa_ok($self, 'Params::Callback'); main::isa_ok($self, __PACKAGE__); my $params = $self->params; $params->{result} = 'Simple Success'; } sub lowerit : PostCallback { my $self = shift; my $params = $self->params; if ($params->{do_lower}) { main::isa_ok($self, 'Params::Callback'); main::isa_ok($self, __PACKAGE__); $params->{result} = lc $params->{result}; } } 1; ############################################################################## # Set up another callback class to test the default class key. package Params::Callback::TestKey; use strict; use base 'Params::Callback'; __PACKAGE__->register_subclass; sub my_key : Callback { my $self = shift; main::is($self->pkg_key, __PACKAGE__, "Check package key" ); main::is($self->class_key, __PACKAGE__, "Check class key" ); } ############################################################################## # Back in the real world... ############################################################################## package main; use strict; use_ok('Params::CallbackRequest'); ############################################################################## # Set up a functional callback we can use. sub another { my $cb = shift; main::isa_ok($cb, 'Params::Callback'); my $params = $cb->params; $params->{result} = 'Another Success'; } ############################################################################## # And a functional request callback. sub presto { my $cb = shift; main::isa_ok($cb, 'Params::Callback'); my $params = $cb->params; $params->{result} = 'PRESTO' if $params->{do_presto}; } ############################################################################## # Construct the combined callback exec object. ok( my $cb_request = Params::CallbackRequest->new ( callbacks => [{ pkg_key => 'foo', cb_key => 'another', cb => \&another}], cb_classes => 'ALL', pre_callbacks => [\&presto] ), "Construct combined CBExec object" ); ############################################################################## # Make sure the functional callback works. my %params = ( 'foo|another_cb' => 1); ok( $cb_request->request(\%params), "Execute functional callback" ); is( $params{result}, 'Another Success', "Check functional result" ); ############################################################################## # Make sure OO callback works. %params = ( "$base_key|simple_cb" => 1); ok( $cb_request->request(\%params), "Execute OO callback" ); is( $params{result}, 'Simple Success', "Check OO result" ); ############################################################################## # Make sure that functional and OO request callbacks execute, too. %params = ( do_lower => 1, do_presto => 1); ok( $cb_request->request(\%params), "Execute request callbacks" ); is( $params{result}, 'presto', "Check request result" ); ############################################################################## # Make sure that the default class key is the class name. %params = ( "Params::Callback::TestKey|my_key_cb" => 1); ok( $cb_request->request(\%params), "Execute class key callback" ); 1; __END__ Params-CallbackRequest-1.20/t/08apache.t000444000765000024 656111600551467 17470 0ustar00davidstaff000000000000#!perl -w use strict; use Test::More; my $key = 'myCallbackTester'; my $cbs = []; BEGIN { plan skip_all => 'Testing of apache_req requires Apache::FakeRequest' unless eval { require Apache::FakeRequest }; plan tests => 15; use_ok('Params::CallbackRequest'); } ############################################################################## # Make sure that Apache::FakeRequest inherits from Apache, and set up headers # class for Apache::FakeRequest. @Apache::FakeRequest::ISA = qw(Apache) unless @Apache::FakeRequest::ISA; package Params::Callback::Test::Headers; sub unset {} sub new { bless {} } sub add { my ($self, $key, $val) = @_; $self->{$key} = $val; } package main; ############################################################################## # Set up a redirection callback function. my $url = 'http://example.com/'; sub redir { my $cb = shift; my $val = $cb->value; $cb->redirect($url, $val); } push @$cbs, { pkg_key => $key, cb_key => 'redir', cb => \&redir }; # Set up a callback to check the redirected URL. sub chk_url { my $cb = shift; my $val = $cb->value; main::is( $cb->redirected, $val, "Check redirected is '" . ($val || 'undef') . "'" ); } push @$cbs, { pkg_key => $key, cb_key => 'chk_url', cb => \&chk_url }; ############################################################################## # Create the callback request object. ok( my $cb_request = Params::CallbackRequest->new( callbacks => $cbs ), "Construct CBExec object" ); isa_ok($cb_request, 'Params::CallbackRequest' ); # Create an Apache request object. ok( my $headers_in = Params::Callback::Test::Headers->new, "Create headers_in object" ); ok( my $err_headers_out = Params::Callback::Test::Headers->new, "Create err_headers_out object" ); ok( my $apache_req = Apache::FakeRequest->new( headers_in => $headers_in, err_headers_out => $err_headers_out, ), "Create apache request object" ); # Execute the delayed redirection callback. my %params = ( "$key|redir_cb" => 1, "$key|chk_url_cb9" => $url ); is( $cb_request->request(\%params, apache_req => $apache_req), 302, "Execute delayed redir callback" ); # Check apache request values. is_deeply $apache_req->{err_headers_out}, { Location => $url }, "Check err_header_out"; delete $apache_req->{err_headers_out}{Location}; is( delete $apache_req->{method}, 'GET', "Check request method" ); ############################################################################## # Now execute an instant redirection (that is, with abort). %params = ( "$key|redir_cb" => 0 ); is( $cb_request->request(\%params, apache_req => $apache_req), 302, "Execute instant redir callback" ); # Check the Apache settings again. is_deeply $apache_req->{err_headers_out}, { Location => $url }, "Check err_header_out"; delete $apache_req->{err_headers_out}{Location}; is( delete $apache_req->{method}, 'GET', "Check request method" ); ############################################################################## # Now make sure that if there is no redirection that redirectd returns false, # and that no abort status is returned. %params = ( "$key|chk_url_cb" => undef ); is( $cb_request->request(\%params, apache_req => $apache_req), $cb_request, "Execute no redir callback" ); 1; __END__ Params-CallbackRequest-1.20/t/09pod.t000444000765000024 27411600551467 17005 0ustar00davidstaff000000000000#!/usr/bin/perl -w use strict; use Test::More; eval "use Test::Pod 1.41"; plan skip_all => "Test::Pod 1.41 required for testing POD" if $@; all_pod_files_ok(all_pod_files('bin', 'lib'));