File Coverage

blib/lib/Params/Callback.pm

Criterion	Covered	Total	%
statement	135	151	89.4
branch	28	50	56.0
condition	12	23	52.1
subroutine	30	33	90.9
pod	8	10	80.0
total	213	267	79.7

package 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__