line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# Copyright (C) 2006, David Muir Sharnoff |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
package Plugins::API; |
4
|
|
|
|
|
|
|
|
5
|
1
|
|
|
1
|
|
740
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
39
|
|
6
|
1
|
|
|
1
|
|
6
|
use warnings; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
35
|
|
7
|
1
|
|
|
1
|
|
5
|
use Scalar::Util qw(weaken refaddr); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
60
|
|
8
|
1
|
|
|
1
|
|
5
|
use Carp qw(cluck confess); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
3213
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
our $VERSION = 0.3; |
11
|
|
|
|
|
|
|
our $debug = 0; |
12
|
|
|
|
|
|
|
our $AUTOLOAD; |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
my $debug_disable = 0; |
15
|
|
|
|
|
|
|
my $debug_register = 0; |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
sub new |
18
|
|
|
|
|
|
|
{ |
19
|
2
|
|
|
2
|
1
|
5515
|
my $pkg = shift; |
20
|
2
|
100
|
|
|
|
25
|
my $flags = ref($_[0]) |
21
|
|
|
|
|
|
|
? shift |
22
|
|
|
|
|
|
|
: undef; |
23
|
2
|
|
|
|
|
43
|
my $self = bless { |
24
|
|
|
|
|
|
|
api => {}, |
25
|
|
|
|
|
|
|
handlers => {}, |
26
|
|
|
|
|
|
|
disabled => {}, |
27
|
|
|
|
|
|
|
enabled => {}, |
28
|
|
|
|
|
|
|
handler_class => 'Plugins::API::Handler', |
29
|
|
|
|
|
|
|
}, $pkg; |
30
|
2
|
50
|
|
|
|
53
|
$self->{default_handler} = $self->can('callhandler') or die; |
31
|
2
|
50
|
|
|
|
13
|
confess "odd # of elements in @_" |
32
|
|
|
|
|
|
|
if @_ % 2 == 1; |
33
|
2
|
100
|
|
|
|
16
|
$self->api(@_) if @_; |
34
|
2
|
100
|
|
|
|
18
|
return $self unless $flags; |
35
|
1
|
50
|
|
|
|
18
|
if ($flags->{autoregister}) { |
36
|
1
|
|
|
|
|
18
|
$self->autoregister($flags->{autoregister}); |
37
|
|
|
|
|
|
|
} |
38
|
1
|
50
|
|
|
|
5
|
if ($flags->{plugins}) { |
39
|
0
|
|
|
|
|
0
|
$self->{plugins} = $flags->{plugins}; |
40
|
0
|
|
|
|
|
0
|
weaken($self->{plugins}); |
41
|
|
|
|
|
|
|
} |
42
|
1
|
|
|
|
|
5
|
return $self; |
43
|
|
|
|
|
|
|
} |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
sub api |
46
|
|
|
|
|
|
|
{ |
47
|
2
|
|
|
2
|
1
|
28
|
my ($self, %api) = @_; |
48
|
2
|
|
|
|
|
12
|
for my $callback (keys %api) { |
49
|
6
|
|
|
|
|
9
|
my $v = $api{$callback}; |
50
|
6
|
50
|
|
|
|
25
|
$v = {} unless ref $v; |
51
|
6
|
50
|
33
|
|
|
26
|
unless ($self->{api}{$callback} && ! $api{$callback}->{override_api}) { |
52
|
6
|
50
|
|
|
|
18
|
print "API: $callback ($self)\n" if $debug_register; |
53
|
6
|
|
|
|
|
27
|
$self->{api}{$callback} = $v; |
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
} |
56
|
2
|
|
|
|
|
9
|
return $self->{api}; |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
sub autoregister |
60
|
|
|
|
|
|
|
{ |
61
|
2
|
|
|
2
|
1
|
11
|
my ($self, $caller) = @_; |
62
|
2
|
50
|
|
|
|
6
|
$caller = caller() unless $caller; |
63
|
2
|
50
|
|
|
|
6
|
print STDERR "AUTOREGISTER $caller\n" if $debug_register; |
64
|
2
|
|
|
|
|
3
|
for my $callback (keys %{$self->{api}}) { |
|
2
|
|
|
|
|
11
|
|
65
|
6
|
50
|
|
|
|
14
|
print STDERR "? $callback\n" if $debug_register; |
66
|
6
|
|
|
|
|
12
|
my $cref; |
67
|
6
|
50
|
|
|
|
118
|
if (($cref = $caller->can($callback))) { |
68
|
0
|
0
|
|
|
|
0
|
print STDERR "Autoregister $caller: $callback\n" if $debug_register; |
69
|
0
|
|
|
|
|
0
|
push(@{$self->{handlers}{$callback}}, $self->newhandler($caller, $cref)); |
|
0
|
|
|
|
|
0
|
|
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
} |
72
|
2
|
|
|
|
|
17
|
$self->{enabled} = {}; |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
sub register |
76
|
|
|
|
|
|
|
{ |
77
|
21
|
|
|
21
|
1
|
93
|
my $self = shift; |
78
|
21
|
|
|
|
|
30
|
my $caller = shift; |
79
|
21
|
|
|
|
|
28
|
my $options = {}; |
80
|
21
|
50
|
|
|
|
47
|
if (ref $_[0]) { |
81
|
0
|
|
|
|
|
0
|
$options = shift; |
82
|
|
|
|
|
|
|
} |
83
|
21
|
|
|
|
|
49
|
my (%handlers) = @_; |
84
|
21
|
|
|
|
|
43
|
for my $callback (keys %handlers) { |
85
|
21
|
|
|
|
|
51
|
my $handler = $self->newhandler($caller, $handlers{$callback}); |
86
|
21
|
50
|
|
|
|
61
|
if ($options->{first}) { |
|
|
50
|
|
|
|
|
|
87
|
0
|
|
|
|
|
0
|
unshift(@{$self->{handlers}{$callback}}, $handler); |
|
0
|
|
|
|
|
0
|
|
88
|
|
|
|
|
|
|
} elsif ($options->{replace}) { |
89
|
0
|
|
|
|
|
0
|
@{$self->{handlers}{$callback}} = ($handler); |
|
0
|
|
|
|
|
0
|
|
90
|
|
|
|
|
|
|
} else { |
91
|
21
|
|
|
|
|
25
|
push(@{$self->{handlers}{$callback}}, $handler); |
|
21
|
|
|
|
|
78
|
|
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
} |
94
|
21
|
|
|
|
|
83
|
$self->{enabled} = {}; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
sub newhandler |
98
|
|
|
|
|
|
|
{ |
99
|
21
|
|
|
21
|
0
|
31
|
my ($self, $caller, $cref) = @_; |
100
|
21
|
|
|
|
|
77
|
my $handler = bless [ $caller, $cref ], $self->{handler_class}; |
101
|
21
|
100
|
|
|
|
141
|
weaken($handler->[0]) |
102
|
|
|
|
|
|
|
if ref $caller; |
103
|
21
|
|
|
|
|
39
|
return $handler; |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
sub handlers |
107
|
|
|
|
|
|
|
{ |
108
|
4
|
|
|
4
|
1
|
7
|
my ($self, $callback) = @_; |
109
|
4
|
|
|
|
|
8
|
my $api = $self->{api}{$callback}; |
110
|
4
|
|
|
|
|
7
|
my $found; |
111
|
|
|
|
|
|
|
my $handlers; |
112
|
4
|
50
|
|
|
|
12
|
if ($self->{plugins}) { |
113
|
0
|
|
|
|
|
0
|
for my $plugin ($self->{plugins}->plugins) { |
114
|
0
|
|
|
|
|
0
|
my $f = $plugin->can($callback); |
115
|
0
|
0
|
|
|
|
0
|
next unless $f; |
116
|
0
|
|
|
|
|
0
|
$found = 1; |
117
|
0
|
0
|
|
|
|
0
|
next if $self->{disabled}{refaddr($plugin)}; |
118
|
0
|
0
|
|
|
|
0
|
next if $self->{disabled}{ref($plugin)}; |
119
|
0
|
0
|
|
|
|
0
|
printf STDERR "Not disabled: %s / %s / %s\n", $plugin, refaddr($plugin), ref($plugin) if $debug_disable; |
120
|
0
|
|
|
|
|
0
|
push(@$handlers, $self->newhandler($plugin, $f)); |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
} |
123
|
4
|
50
|
33
|
|
|
15
|
unless ($self->{handlers}{$callback} || $found) { |
124
|
0
|
0
|
|
|
|
0
|
unless ($api) { |
125
|
0
|
|
|
|
|
0
|
cluck "Call to unregistered api: '$callback'"; |
126
|
0
|
|
|
|
|
0
|
return; |
127
|
|
|
|
|
|
|
} |
128
|
0
|
0
|
|
|
|
0
|
unless ($api->{optional}) { |
129
|
0
|
|
|
|
|
0
|
cluck "No handler for call to '$callback'"; |
130
|
0
|
|
|
|
|
0
|
return; |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
} |
133
|
4
|
100
|
|
|
|
14
|
if ($self->{enabled}{$callback}) { |
134
|
1
|
|
|
|
|
3
|
$handlers = $self->{enabled}{$callback}; |
135
|
|
|
|
|
|
|
} else { |
136
|
3
|
|
|
|
|
4
|
for my $h (@{$self->{handlers}{$callback}}) { |
|
3
|
|
|
|
|
10
|
|
137
|
9
|
|
|
|
|
22
|
my $obj = $h->object; |
138
|
9
|
100
|
66
|
|
|
90
|
next if ref($obj) && ($self->{disabled}{ref($obj)} || $self->{disabled}{refaddr($obj)}); |
|
|
|
33
|
|
|
|
|
139
|
8
|
50
|
33
|
|
|
21
|
printf STDERR "Not disabled: %s / %s / %s\n", $obj, refaddr($obj), ref($obj) if $debug_disable && ref($obj); |
140
|
8
|
|
|
|
|
15
|
push(@$handlers, $h); |
141
|
|
|
|
|
|
|
} |
142
|
3
|
|
|
|
|
11
|
$self->{enabled}{$callback} = $handlers; |
143
|
|
|
|
|
|
|
} |
144
|
4
|
50
|
|
|
|
9
|
print STDERR "HANDLERS: ".join(", ",map { refaddr($_) } @$handlers), "\n" if $debug_disable; |
|
0
|
|
|
|
|
0
|
|
145
|
4
|
|
|
|
|
10
|
return $handlers; |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
sub invoke |
149
|
|
|
|
|
|
|
{ |
150
|
4
|
|
|
4
|
1
|
381
|
my ($self, $callback, @args) = @_; |
151
|
4
|
|
|
|
|
8
|
my $api = $self->{api}{$callback}; |
152
|
4
|
|
|
|
|
13
|
my $handlers = $self->handlers($callback); |
153
|
4
|
50
|
33
|
|
|
27
|
my $callhandler = ($api && $api->{callhandler}) |
154
|
|
|
|
|
|
|
? $api->{callhandler} |
155
|
|
|
|
|
|
|
: $self->{default_handler}; |
156
|
4
|
|
|
|
|
11
|
return &$callhandler($self, $callback, $api, \@args, $handlers); |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
sub callhandler |
160
|
|
|
|
|
|
|
{ |
161
|
4
|
|
|
4
|
0
|
15
|
my ($self, $callback, $api, $args, $handlers) = @_; |
162
|
4
|
|
|
|
|
9
|
my @rrr; |
163
|
|
|
|
|
|
|
my @rr; |
164
|
0
|
|
|
|
|
0
|
my @r; |
165
|
4
|
|
|
|
|
8
|
for my $handler (@$handlers) { |
166
|
9
|
50
|
|
|
|
21
|
if ($api->{first_only}) { |
167
|
0
|
|
|
|
|
0
|
return $handler->call(@$args); |
168
|
|
|
|
|
|
|
} |
169
|
9
|
100
|
|
|
|
13
|
if (wantarray) { |
170
|
8
|
|
|
|
|
21
|
@r = $handler->call(@$args); |
171
|
|
|
|
|
|
|
} else { |
172
|
1
|
|
|
|
|
5
|
$r[0] = $handler->call(@$args); |
173
|
|
|
|
|
|
|
} |
174
|
9
|
100
|
66
|
|
|
96
|
return $r[0] if defined($r[0]) and $api->{first_defined}; |
175
|
8
|
50
|
|
|
|
22
|
if ($api->{exit_test}) { |
176
|
0
|
|
|
|
|
0
|
my $t = $api->{exit_test}; |
177
|
0
|
|
|
|
|
0
|
my ($q, @rv) = &$t(\@r, \@rr, \@rrr, wantarray); |
178
|
0
|
0
|
|
|
|
0
|
return @rv if $q; |
179
|
|
|
|
|
|
|
} |
180
|
8
|
|
|
|
|
13
|
push(@rr, \@r); |
181
|
8
|
|
|
|
|
16
|
push(@rrr, @r); |
182
|
|
|
|
|
|
|
} |
183
|
3
|
50
|
|
|
|
46
|
return @rrr if $api->{combine_returns}; |
184
|
0
|
0
|
|
|
|
0
|
return @rr if $api->{array_return}; |
185
|
0
|
0
|
|
|
|
0
|
return @r if wantarray; |
186
|
0
|
|
|
|
|
0
|
return $r[0]; |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
sub disable |
190
|
|
|
|
|
|
|
{ |
191
|
1
|
|
|
1
|
1
|
1283
|
my ($self, $plugin) = @_; |
192
|
1
|
50
|
|
|
|
7
|
my $addr = ref($plugin) |
193
|
|
|
|
|
|
|
? refaddr($plugin) |
194
|
|
|
|
|
|
|
: $plugin; |
195
|
1
|
50
|
|
|
|
4
|
print STDERR "Disabling $addr\n" if $debug_disable; |
196
|
1
|
|
|
|
|
4
|
$self->{disabled}{$addr} = caller; |
197
|
1
|
|
|
|
|
3
|
$self->{enabled} = {}; |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
sub plugins |
201
|
|
|
|
|
|
|
{ |
202
|
1
|
|
|
1
|
1
|
9
|
my ($self, $plugins) = @_; |
203
|
1
|
|
|
|
|
2
|
my $old = $self->{plugins}; |
204
|
1
|
50
|
|
|
|
5
|
$self->{plugins} = $plugins if @_ > 1; |
205
|
1
|
|
|
|
|
2
|
return $old; |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
|
208
|
0
|
|
|
0
|
|
0
|
sub DESTROY {} |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
sub AUTOLOAD |
211
|
|
|
|
|
|
|
{ |
212
|
2
|
|
|
2
|
|
1832
|
my $self = shift; |
213
|
|
|
|
|
|
|
|
214
|
2
|
|
|
|
|
5
|
my $auto = $AUTOLOAD; |
215
|
2
|
|
|
|
|
4
|
my $ref = ref($self); |
216
|
2
|
|
|
|
|
3
|
my $p = __PACKAGE__; |
217
|
2
|
50
|
|
|
|
25
|
$auto =~ s/^${ref}::// or $auto =~ s/^${p}:://; |
218
|
2
|
50
|
33
|
|
|
23
|
if ($self->{plugins} || $self->{api}{$auto} || $self->{handlers}{$auto}) { |
|
|
|
33
|
|
|
|
|
219
|
2
|
|
|
|
|
6
|
return $self->invoke($auto, @_); |
220
|
|
|
|
|
|
|
} |
221
|
0
|
|
|
|
|
0
|
cluck "No api or handler for '$auto'"; |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
package Plugins::API::Handler; |
225
|
|
|
|
|
|
|
|
226
|
1
|
|
|
1
|
|
10
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
55
|
|
227
|
1
|
|
|
1
|
|
7
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
35
|
|
228
|
1
|
|
|
1
|
|
7
|
use Carp; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
243
|
|
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
sub call |
231
|
|
|
|
|
|
|
{ |
232
|
9
|
|
|
9
|
|
19
|
my ($self, @args) = @_; |
233
|
9
|
|
33
|
|
|
24
|
my (@obj) = $self->[0] || (); |
234
|
9
|
|
|
|
|
11
|
my $method = $self->[1]; |
235
|
9
|
|
|
|
|
25
|
&$method(@obj, @args); |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
sub object |
239
|
|
|
|
|
|
|
{ |
240
|
9
|
|
|
9
|
|
11
|
my $self = shift; |
241
|
9
|
50
|
|
|
|
37
|
$self->[0] or (); |
242
|
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
sub method |
245
|
|
|
|
|
|
|
{ |
246
|
0
|
|
|
0
|
|
|
my $self = shift; |
247
|
0
|
|
|
|
|
|
return $self->[1]; |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
1; |