Changeset 1807

Show
Ignore:
Timestamp:
05/09/06 03:13:28
Author:
miyagawa
Message:

applied a patch from timappnel. waiting for .t files

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved
  • Class-Trigger/trunk/Makefile.PL

    r400 r1807  
    77        Class::Data::Inheritable => 0.02, 
    88        IO::Scalar => 0, 
     9        Class::ISA => 0, 
    910    }, 
    1011); 
  • Class-Trigger/trunk/lib/Class/Trigger.pm

    r1618 r1807  
    33use strict; 
    44use vars qw($VERSION); 
    5 $VERSION = "0.10"; 
     5$VERSION = "0.101"; 
    66 
    77use Class::Data::Inheritable; 
     
    2121    $pkg->mk_classdata('__triggerpoints'); 
    2222 
    23     $pkg->__triggerpoints({ map { $_ => 1 } @_ }) if @_; 
     23    $pkg->__triggerpoints({ map { lc $_ => 1 } @_ }) if @_; 
    2424 
    2525    # export mixin methods 
    2626    no strict 'refs'; 
    27     my @methods = qw(add_trigger call_trigger); 
     27    my @methods = qw(add_trigger new_trigger call_trigger call_deep_trigger); 
    2828    *{"$pkg\::$_"} = \&{$_} for @methods; 
    2929} 
     
    4343} 
    4444 
     45# Create a new trigger point after import. 
     46sub new_trigger { 
     47    my $proto = shift; 
     48    my $points = $proto->__triggerpoints || {}; 
     49    map { $points->{lc $_} = 1 } @_; 
     50    $points->__triggerpoints($points); 
     51} 
     52 
    4553sub call_trigger { 
    4654    my $self = shift; 
    4755    return unless my $all_triggers = __fetch_triggers($self); # any triggers? 
    4856    my $when = shift; 
    49     if (my $triggers = $all_triggers->{$when}) { 
     57    if (my $triggers = $all_triggers->{lc $when}) { 
    5058        for my $trigger (@$triggers) { 
    5159            $trigger->($self, @_); 
     
    6068} 
    6169 
     70use Class::ISA; 
     71 
     72# Run triggers descending from object (if specified) then class down  
     73# through its ancessors. A port of CGI::Application::call_hook method. 
     74sub call_deep_trigger { 
     75    my $self = shift; 
     76    my $when = lc shift; 
     77    my @args = @_; 
     78    my $self_class = ref $self || $self; 
     79    my %has_run; 
     80    __validate_triggerpoint($self, $when); # the right thing? 
     81    my @path = Class::ISA::self_and_super_path($self_class); 
     82    unshift @path, $self if ref $self; # if called from an object add to the front of the line 
     83    foreach my $p (@path) { # walk class hierarchy and run triggers making sure not to run the same one twice. 
     84        next unless my $all_triggers = __fetch_triggers($p); 
     85        if (my $triggers = $all_triggers->{$when}) { 
     86            for my $trigger (@$triggers) { 
     87                next if $has_run{$trigger}; 
     88                $trigger->($p, @args); 
     89                $has_run{$trigger} = 1; 
     90            } 
     91        } 
     92    } 
     93} 
     94 
    6295sub __validate_triggerpoint { 
    6396    return unless my $points = $_[0]->__triggerpoints; 
    6497    my ($self, $when) = @_; 
    6598    Carp::croak("$when is not valid triggerpoint for ".(ref($self) ? ref($self) : $self)) 
    66         unless $points->{$when}; 
     99        unless $points->{lc $when}; 
    67100} 
    68101