Changeset 2168

Show
Ignore:
Timestamp:
02/23/07 12:05:22
Author:
miyagawa
Message:

apply patches from Brad

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved
  • Class-Trigger/trunk/Changes

    r1618 r2168  
    11Revision history for Perl extension Class::Trigger. 
     2 
     30.11  Thu Feb 22 19:02:09 PST 2007 
     4        - Fixed a bug due to Class::Data::Inheritable, where 
     5          triggers added to the superclass after trigger is added in 
     6          the child class are ignored in the child class. 
     7          See t/03_inherit.t for example. 
     8          (Thanks to Brad Choate, Yann Kerherve and Ben Trott) 
    29 
    3100.10  Tue Aug 23 22:11:21 UTC 2005 
  • Class-Trigger/trunk/lib/Class/Trigger.pm

    r1807 r2168  
    33use strict; 
    44use vars qw($VERSION); 
    5 $VERSION = "0.101"; 
    6  
    7 use Class::Data::Inheritable; 
     5$VERSION = "0.10_01"; 
     6 
    87use Carp (); 
     8 
     9my (%Triggers, %TriggerPoints); 
    910 
    1011sub import { 
     
    1213    my $pkg = caller(0); 
    1314 
    14     # XXX 5.005_03 isa() is broken with MI 
    15     unless ($pkg->can('mk_classdata')) { 
    16         no strict 'refs'; 
    17         push @{"$pkg\::ISA"}, 'Class::Data::Inheritable'; 
    18     } 
    19  
    20     $pkg->mk_classdata('__triggers'); 
    21     $pkg->mk_classdata('__triggerpoints'); 
    22  
    23     $pkg->__triggerpoints({ map { lc $_ => 1 } @_ }) if @_; 
     15    $TriggerPoints{$pkg} = { map { $_ => 1 } @_ } if @_; 
    2416 
    2517    # export mixin methods 
    2618    no strict 'refs'; 
    27     my @methods = qw(add_trigger new_trigger call_trigger call_deep_trigger); 
     19    my @methods = qw(add_trigger call_trigger); 
    2820    *{"$pkg\::$_"} = \&{$_} for @methods; 
    2921} 
     
    3224    my $proto = shift; 
    3325 
    34     # should be deep copy of the hash: for inheritance 
    35     my $old_triggers = __fetch_triggers($proto) || {}; 
    36     my %triggers = __deep_dereference($old_triggers); 
     26    my $triggers = __fetch_triggers($proto); 
    3727    while (my($when, $code) = splice @_, 0, 2) { 
    38         __validate_triggerpoint($proto, $when); 
    39         Carp::croak('add_trigger() needs coderef') unless ref($code) eq 'CODE'; 
    40         push @{$triggers{$when}}, $code; 
    41     } 
    42     __update_triggers($proto, \%triggers); 
    43 
    44  
    45 # Create a new trigger point after import. 
    46 sub new_trigger { 
    47     my $proto = shift; 
    48     my $points = $proto->__triggerpoints || {}; 
    49     map { $points->{lc $_} = 1 } @_; 
    50     $points->__triggerpoints($points); 
     28        __validate_triggerpoint($proto, $when); 
     29        Carp::croak('add_trigger() needs coderef') unless ref($code) eq 'CODE'; 
     30        push @{$triggers->{$when}}, $code; 
     31    } 
     32 
     33    1; 
    5134} 
    5235 
    5336sub call_trigger { 
    5437    my $self = shift; 
    55     return unless my $all_triggers = __fetch_triggers($self); # any triggers? 
    5638    my $when = shift; 
    57     if (my $triggers = $all_triggers->{lc $when}) { 
    58         for my $trigger (@$triggers) { 
    59             $trigger->($self, @_); 
    60         } 
     39 
     40    if (my @triggers = __fetch_all_triggers($self, $when)) { # any triggers? 
     41        $_->($self, @_) for @triggers; 
    6142    } 
    6243    else { 
    63         # if validation is enabled we can only add valid trigger points 
    64         # so we only need to check in call_trigger() if there's no 
    65         # trigger with the requested name. 
    66         __validate_triggerpoint($self, $when); 
    67     } 
    68 
    69  
    70 use 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. 
    74 sub 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; 
     44        # if validation is enabled we can only add valid trigger points 
     45        # so we only need to check in call_trigger() if there's no 
     46        # trigger with the requested name. 
     47        __validate_triggerpoint($self, $when); 
     48    } 
     49
     50 
     51sub __fetch_all_triggers { 
     52    my ($obj, $when, $list, $order) = @_; 
     53    my $class = ref $obj || $obj; 
     54    my $return; 
     55    unless ($list) { 
     56        # Absence of the $list parameter conditions the creation of 
     57        # the unrolled list of triggers. These keep track of the unique 
     58        # set of triggers being collected for each class and the order 
     59        # in which to return them (based on hierarchy; base class 
     60        # triggers are returned ahead of descendant class triggers). 
     61        $list = {}; 
     62        $order = []; 
     63        $return = 1; 
     64    } 
     65    no strict 'refs'; 
     66    my @classes = @{$class . '::ISA'}; 
     67    push @classes, $class; 
     68    foreach my $c (@classes) { 
     69        next if $list->{$c}; 
     70        if (UNIVERSAL::can($c, 'call_trigger')) { 
     71            $list->{$c} = []; 
     72            __fetch_all_triggers($c, $when, $list, $order) 
     73                unless $c eq $class; 
     74            if (defined $when && $Triggers{$c}{$when}) { 
     75                push @$order, $c; 
     76                $list->{$c} = $Triggers{$c}{$when}; 
    9077            } 
    9178        } 
    9279    } 
     80    if ($return) { 
     81        my @triggers; 
     82        foreach my $class (@$order) { 
     83            push @triggers, @{ $list->{$class} }; 
     84        } 
     85        if (ref $obj && defined $when) { 
     86            my $obj_triggers = $obj->{__triggers}{$when}; 
     87            push @triggers, @$obj_triggers if $obj_triggers; 
     88        } 
     89        return @triggers; 
     90    } 
    9391} 
    9492 
    9593sub __validate_triggerpoint { 
    96     return unless my $points = $_[0]->__triggerpoints
     94    return unless my $points = $TriggerPoints{ref $_[0] || $_[0]}
    9795    my ($self, $when) = @_; 
    9896    Carp::croak("$when is not valid triggerpoint for ".(ref($self) ? ref($self) : $self)) 
    99        unless $points->{lc $when}; 
     97        unless $points->{$when}; 
    10098} 
    10199 
    102100sub __fetch_triggers { 
    103     my $proto = shift
     101    my ($obj, $proto) = @_
    104102    # check object based triggers first 
    105     return (ref $proto and $proto->{__triggers}) || $proto->__triggers; 
    106 
    107  
    108 sub __update_triggers { 
    109     my($proto, $triggers) = @_; 
    110     if (ref $proto) { 
    111         # object attributes 
    112         $proto->{__triggers} = $triggers; 
    113     } 
    114     else { 
    115         # class data inheritable 
    116         $proto->__triggers($triggers); 
    117     } 
    118 
    119  
    120 sub __deep_dereference { 
    121     my $hashref = shift; 
    122     my %copy; 
    123     while (my($key, $arrayref) = each %$hashref) { 
    124         $copy{$key} = [ @$arrayref ]; 
    125     } 
    126     return %copy; 
     103    return ref $obj ? $obj->{__triggers} ||= {} : $Triggers{$obj} ||= {}; 
    127104} 
    128105 
     
    153130 
    154131  my $foo = Foo->new; 
    155   $foo->foo;                   # then sub1, sub2 called 
     132  $foo->foo;            # then sub1, sub2 called 
    156133 
    157134  # triggers are inheritable 
     
    163140  # triggers can be object based 
    164141  $foo->add_trigger(after_foo => \&sub3); 
    165   $foo->foo;                   # sub3 would appply only to this object 
     142  $foo->foo;            # sub3 would appply only to this object 
    166143 
    167144=head1 DESCRIPTION 
  • Class-Trigger/trunk/t/03_inherit.t

    r625 r2168  
    11use strict; 
    2 use Test::More tests => 5
     2use Test::More tests => 6
    33 
    44use IO::Scalar; 
     
    1414ok(Foo::Bar->add_trigger(before_foo  => sub { print "before_foo2\n" }), 
    1515   'add_trigger in Foo::Bar'); 
     16ok(Foo->add_trigger(before_foo => sub { print "before_foo3\n" }), 
     17   'add_trigger in Foo'); 
    1618 
    1719my $foo = Foo::Bar->new; 
     
    2022    tie *STDOUT, 'IO::Scalar', \my $out; 
    2123    $foo->foo; 
    22     is $out, "before_foo\nbefore_foo2\nfoo\nafter_foo\n"; 
     24    is $out, "before_foo\nbefore_foo3\nbefore_foo2\nfoo\nafter_foo\n"; 
    2325} 
    2426 
     
    2729    tie *STDOUT, 'IO::Scalar', \my $out; 
    2830    $foo_parent->foo; 
    29     is $out, "before_foo\nfoo\n", 'Foo not affected'; 
     31    is $out, "before_foo\nbefore_foo3\nfoo\n", 'Foo not affected'; 
    3032} 
    3133 
    3234 
     35