File Coverage

blib/lib/Hook/Queue.pm

Criterion	Covered	Total	%
statement	37	38	97.3
branch	3	4	75.0
condition			n/a
subroutine	9	9	100.0
pod	0	1	0.0
total	49	52	94.2

package Hook::Queue;
use strict;
use warnings;
use Devel::Peek qw(CvGV);
our $VERSION = 1.21;

=head1 NAME

Hook::Queue - define a queue of handlers

=head1 SYNOPSIS

  # define a Liar class which always claims to be what you're asking
  # about
  package Liar;
  use Hook::Queue 'UNIVERSAL::isa' => sub {
      my $what  = shift;
      my $class = shift;
      return 1 if (ref $what || $what) eq "Liar";
      # it's not my call, pass it down the chain
      return Hook::Queue->defer;
  };

=head1 DESCRIPTION

Hook::Queue provides a mechanism for stacking global handlers in a
queue of routines that will take an attempt at answering the
subroutine call addressed to it.

For each subroutine that joins the queue, it can either return a
canonical answer, or indicate that it's deferring along the queue by
calling the Cdefer> method and returning.

When you say C you join the queue at its current
head, and as such your position may very, depending on compilation
order of the Perl program.  As such you should remember to C
even if your testing shows you to be at the end of the queue in test
circumstances.

=cut

my ($Defer, %Hooks);
sub defer { $Defer = 1 }

sub import {
    my $class = shift;
    my %hooks = @_;
    for my $hook (keys %hooks) {
        my $hooked = do { no strict 'refs'; \&$hook };
        if (CvGV($hooked) ne $hook) {
            # something already lives there, save at the head of the
            # queue and install
            unshift @{ $Hooks{$hook} }, $hooked;
            my $sub = sub {
                for my $segment (@{ $Hooks{ $hook } }) {
                    $Defer = 0;
                    my $ret = $segment->( @_ );
                    next if $Defer;
                    return $ret;
                }
                die "Deferred past the end of the queue of $hook!";
            };

            no strict 'refs';
            no warnings 'redefine';
            *$hook = $sub;
        }
        unshift @{ $Hooks{$hook} }, $hooks{ $hook };
    }
}


1;

__END__