Changeset 856

Show
Ignore:
Timestamp:
02/27/03 15:55:15
Author:
miyagawa
Message:

patches by Tim Bunce

Files:

Legend:

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

    r844 r856  
    11Revision history for Perl extension Class::Trigger. 
     2 
     30.08  Thu Feb 27 15:51:31 JST 2003 
     4        - Performance boostup and document clarification 
     5          (Thanks to Tim Bunce) 
    26 
    370.07  Sat Feb 15 01:01:36 JST 2003 
  • Class-Trigger/trunk/MANIFEST

    r404 r856  
    99t/03_inherit.t 
    1010t/04_object.t 
     11t/05_args.t 
    1112t/lib/Foo.pm 
    1213t/lib/Foo/Bar.pm 
  • Class-Trigger/trunk/lib/Class/Trigger.pm

    r844 r856  
    33use strict; 
    44use vars qw($VERSION); 
    5 $VERSION = 0.07
     5$VERSION = 0.08
    66 
    77use Class::Data::Inheritable; 
     
    3333 
    3434    # should be deep copy of the hash: for inheritance 
    35     my %triggers = __deep_dereference(__fetch_triggers($proto)); 
     35    my $old_triggers = __fetch_triggers($proto) || {}; 
     36    my %triggers = __deep_dereference($old_triggers); 
    3637    while (my($when, $code) = splice @_, 0, 2) { 
    3738        __validate_triggerpoint($proto, $when); 
    38         unless (ref($code) eq 'CODE') { 
    39             Carp::croak('add_trigger() needs coderef'); 
     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 
     45sub call_trigger { 
     46    my $self = shift; 
     47    my $all_triggers = __fetch_triggers($self) || return; # any triggers? 
     48    my $when = shift; 
     49    if (my $triggers = $all_triggers->{$when}) { 
     50        for my $trigger (@$triggers) { 
     51            $trigger->($self, @_); 
    4052        } 
    41         push @{$triggers{$when}}, $code; 
    42     } 
    43     __update_triggers($proto, \%triggers); 
    44 
    45  
    46 sub call_trigger { 
    47     my($self, $when, @args) = @_; 
    48     __validate_triggerpoint(ref($self) || $self, $when); 
    49     my $all_triggers = __fetch_triggers($self); 
    50     my $triggers = $all_triggers->{$when} || []; 
    51     for my $trigger (@{$triggers}) { 
    52         $trigger->($self, @args); 
     53    } 
     54    else { 
     55        # if validation is enabled we can only add valid trigger points 
     56        # so we only need to check in call_trigger() if there's no 
     57        # trigger with the requested name. 
     58        __validate_triggerpoint($self, $when); 
    5359    } 
    5460} 
    5561 
    5662sub __validate_triggerpoint { 
    57     my($class, $when) = @_; 
    58     my $points = $class->__triggerpoints; 
    59     if ($points && ! defined $points->{$when}) { 
    60         Carp::croak("$when is not valid triggerpoint for $class"); 
    61     } 
     63    my $points = $_[0]->__triggerpoints || return; 
     64    my ($self, $when) = @_; 
     65    Carp::croak("$when is not valid triggerpoint for ".(ref($self) || $self)) 
     66        unless $points->{$when}; 
    6267} 
    6368 
    6469sub __fetch_triggers { 
    6570    my $proto = shift; 
    66     if (ref $proto) { 
    67         # first check object based triggers 
    68         return $proto->{__triggers} if defined $proto->{__triggers}; 
    69     } 
    70     return $proto->__triggers || {}; 
     71    # check object based triggers first 
     72    return (ref $proto and $proto->{__triggers}) || $proto->__triggers; 
    7173} 
    7274 
     
    147149 
    148150Adds triggers for trigger point. You can have any number of triggers 
    149 for each point. Each coderef will be passed a copy of the object, and 
     151for each point. Each coderef will be passed a the object reference, and 
    150152return values will be ignored. 
    151153 
    152 If C<add_trigger> is called as object method, whole trigger table will 
    153 be copied onto the object. Then the object should be implemented as 
    154 hash. 
     154If C<add_trigger> is called as object method, whole current trigger 
     155table will be copied onto the object and the new trigger added to 
     156that. (The object must be implemented as hash.) 
    155157 
    156158  my $foo = Foo->new; 
     
    164166  $bar->foo; 
    165167 
     168Any triggers added to the class after adding a trigger to an object 
     169will not be fired for the object because the object now has a private 
     170copy of the triggers. 
     171 
     172 
    166173=item call_trigger 
    167174 
     
    170177Calls triggers for trigger point, which were added via C<add_trigger> 
    171178method. Each triggers will be passed a copy of the object. 
     179Triggers are invoked in the same order they were defined. 
    172180 
    173181=back 
     
    258266Code by Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>. 
    259267 
     268Patches by Tim Buce E<lt>Tim.Bunce@pobox.comE<gt>. 
     269 
    260270This library is free software; you can redistribute it and/or modify 
    261271it under the same terms as Perl itself.