File Coverage

blib/lib/Class/Handler.pm

Criterion	Covered	Total	%
statement	12	47	25.5
branch	0	22	0.0
condition			n/a
subroutine	4	7	57.1
pod	0	2	0.0
total	16	78	20.5

# $Id: Handler.pm,v 1.3 2000/09/12 19:43:02 nwiger Exp $
#################################################################
#
# Copyright (c) 2000, Nathan Wiger
#
# Class::Handler - Create Apache-like pseudoclass event handlers
#
#################################################################

require 5.003;
package Class::Handler;

use strict;
no strict 'refs';
use vars qw(@EXPORT @ISA $VERSION $AUTOLOAD);

use Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(handler nohandler);

# Internal recordkeeping
my %HANDLERS;

# Both of these functions are exported, and basically just work by
# pushing stuff in and out of arrays and hashes. The AUTOLOAD
# routine is then used for the meat of everything.

sub handler ($@) {

   my($handler, @classes) = @_;

   # If no package name, we simply prefix the caller's
   # package name to it.

   my $pkg  = caller;
   $handler = "$pkg\::$handler" unless $handler =~ /^\w+::\w+/;

   # If the handler is new, all we have to do is add Class::Handler
   # to @ISA for the handler name, since we want our own AUTOLOAD
   # to handle method dispatch.

   @{"${handler}::ISA"} = ('Class::Handler') unless exists $HANDLERS{$handler};

   # We push the new classes onto the end of the handler list.
   # We do not allow multiple instances of the same class because
   # this is most likely an error caused by duplicate or overlapping
   # importing of modules.

   for my $c (@classes) {
       next if grep /^$c$/, @{$HANDLERS{$handler}};
       push @{$HANDLERS{$handler}}, $c or return undef;
   }
   return 1;
}


sub nohandler ($@) {

   my($handler, @classes) = @_;

   # First, remove the selected classes from the handler list
   # Again, first check to make sure we have a full pkg name

   my $pkg  = caller;
   $handler = "$pkg\::$handler" unless $handler =~ /^\w+::\w+/;

   my @tmp_classes;
   for my $c (@classes) {
       for my $ec (@{$HANDLERS{$handler}}) {
           next if $c eq $ec;
           push @tmp_classes, $ec;
       }
       $HANDLERS{$handler} = \@tmp_classes;
   }

   # Check to see if we have anything left; if not, remove the
   # @ISA array and delete the %HANDLERS hash entry. Testing
   # @tmp_classes instead of the handlers list will implicitly
   # catch the single-arg syntax used for removing handlers.

   unless (@tmp_classes) {
      undef @{"${handler}::ISA"};
      delete $HANDLERS{$handler};
   }

   return 1;
}

sub AUTOLOAD {

   # This does all the real work, attempting to use each of the
   # methods from a given handler's classes in turn.
   my($ret, @ret);

   # Chop our $AUTOLOAD down
   my($handler, $method) = $AUTOLOAD =~ m/^(.*)::(\w+)$/g;

   # For each class listed in the %HANDLERS list, we try to use
   # its method in turn. If it doesn't exist or returns undef,
   # we go to the next one in line.

   for my $c (@{$HANDLERS{$handler}}) {
       next unless ${c}->can($method);

       # This is the only way we can catch different return contexts
       if (wantarray()) {
           (@ret = ${c}->$method(@_)) ? return(@ret) : next;
       } else {
           ($ret = ${c}->$method(@_)) ? return($ret) : next;
       }
   }
   return undef;
}

1;

__END__