line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# ABSTRACT: Sugar to let you instrument event listeners at a distance |
2
|
|
|
|
|
|
|
package Event::Wrappable; |
3
|
|
|
|
|
|
|
{ |
4
|
|
|
|
|
|
|
$Event::Wrappable::VERSION = '0.1.1'; |
5
|
|
|
|
|
|
|
} |
6
|
3
|
|
|
3
|
|
57230
|
use strict; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
136
|
|
7
|
3
|
|
|
3
|
|
14
|
use warnings; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
99
|
|
8
|
3
|
|
|
3
|
|
16
|
use Scalar::Util qw( refaddr weaken ); |
|
3
|
|
|
|
|
9
|
|
|
3
|
|
|
|
|
422
|
|
9
|
3
|
|
|
|
|
38
|
use Sub::Exporter -setup => { |
10
|
|
|
|
|
|
|
exports => [qw( event event_method )], |
11
|
|
|
|
|
|
|
groups => { default => [qw( event event_method )] }, |
12
|
3
|
|
|
3
|
|
2928
|
}; |
|
3
|
|
|
|
|
45841
|
|
13
|
3
|
|
|
3
|
|
7040
|
use Sub::Clone qw( clone_sub ); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
our %INSTANCES; |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
our @EVENT_WRAPPERS; |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
sub wrap_events { |
20
|
|
|
|
|
|
|
my $class = shift; |
21
|
|
|
|
|
|
|
my( $todo, @wrappers ) = @_; |
22
|
|
|
|
|
|
|
local @EVENT_WRAPPERS = ( @EVENT_WRAPPERS, @wrappers ); |
23
|
|
|
|
|
|
|
$todo->(); |
24
|
|
|
|
|
|
|
} |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
my $LAST_ID; |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
sub _new { |
30
|
|
|
|
|
|
|
my $class = shift; |
31
|
|
|
|
|
|
|
my( $event, $raw_event ) = @_; |
32
|
|
|
|
|
|
|
bless $event, $class; |
33
|
|
|
|
|
|
|
my $storage = $INSTANCES{refaddr $event} = {}; |
34
|
|
|
|
|
|
|
weaken( $storage->{'wrapped'} = $event ); |
35
|
|
|
|
|
|
|
weaken( $storage->{'base'} = $raw_event ); |
36
|
|
|
|
|
|
|
$storage->{'wrappers'} = [ @EVENT_WRAPPERS ]; |
37
|
|
|
|
|
|
|
$storage->{'id'} = ++ $LAST_ID; |
38
|
|
|
|
|
|
|
return $event; |
39
|
|
|
|
|
|
|
} |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
sub event(&) { |
43
|
|
|
|
|
|
|
my( $raw_event ) = @_; |
44
|
|
|
|
|
|
|
my $event = clone_sub $raw_event; |
45
|
|
|
|
|
|
|
if ( @EVENT_WRAPPERS ) { |
46
|
|
|
|
|
|
|
for (reverse @EVENT_WRAPPERS) { |
47
|
|
|
|
|
|
|
$event = $_->($event); |
48
|
|
|
|
|
|
|
} |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
return __PACKAGE__->_new( $event, $raw_event ); |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
sub event_method($$) { |
55
|
|
|
|
|
|
|
my( $object, $method ) = @_; |
56
|
|
|
|
|
|
|
my $method_sub = ref($method) eq 'CODE' ? $method : $object->can($method); |
57
|
|
|
|
|
|
|
return event { unshift @_, $object; goto $method_sub }; |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
sub get_unwrapped { |
61
|
|
|
|
|
|
|
my $self = shift; |
62
|
|
|
|
|
|
|
return $INSTANCES{refaddr $self}->{'base'}; |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
sub get_wrappers { |
66
|
|
|
|
|
|
|
my $self = shift; |
67
|
|
|
|
|
|
|
my $wrappers = ref $self |
68
|
|
|
|
|
|
|
? $INSTANCES{refaddr $self}->{'wrappers'} |
69
|
|
|
|
|
|
|
: \@EVENT_WRAPPERS; |
70
|
|
|
|
|
|
|
return wantarray ? @$wrappers : $wrappers; |
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
sub object_id { |
74
|
|
|
|
|
|
|
my $self = shift; |
75
|
|
|
|
|
|
|
return $INSTANCES{refaddr $self}->{'id'}; |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
sub DESTROY { |
79
|
|
|
|
|
|
|
my $self = shift; |
80
|
|
|
|
|
|
|
delete $INSTANCES{refaddr $self}; |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
sub CLONE { |
84
|
|
|
|
|
|
|
my $self = shift; |
85
|
|
|
|
|
|
|
foreach (keys %INSTANCES) { |
86
|
|
|
|
|
|
|
my $object = $INSTANCES{$_}{'wrapped'}; |
87
|
|
|
|
|
|
|
$INSTANCES{refaddr $object} = $INSTANCES{$_}; |
88
|
|
|
|
|
|
|
delete $INSTANCES{$_}; |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
1; |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
__END__ |