line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
8
|
|
|
8
|
|
4111
|
use strict; |
|
8
|
|
|
|
|
13
|
|
|
8
|
|
|
|
|
269
|
|
2
|
8
|
|
|
8
|
|
38
|
use warnings; |
|
8
|
|
|
|
|
11
|
|
|
8
|
|
|
|
|
413
|
|
3
|
|
|
|
|
|
|
package Sub::Install; |
4
|
|
|
|
|
|
|
# ABSTRACT: install subroutines into packages easily |
5
|
|
|
|
|
|
|
$Sub::Install::VERSION = '0.928'; |
6
|
8
|
|
|
8
|
|
40
|
use Carp; |
|
8
|
|
|
|
|
13
|
|
|
8
|
|
|
|
|
634
|
|
7
|
8
|
|
|
8
|
|
41
|
use Scalar::Util (); |
|
8
|
|
|
|
|
17
|
|
|
8
|
|
|
|
|
9965
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
#pod =head1 SYNOPSIS |
10
|
|
|
|
|
|
|
#pod |
11
|
|
|
|
|
|
|
#pod use Sub::Install; |
12
|
|
|
|
|
|
|
#pod |
13
|
|
|
|
|
|
|
#pod Sub::Install::install_sub({ |
14
|
|
|
|
|
|
|
#pod code => sub { ... }, |
15
|
|
|
|
|
|
|
#pod into => $package, |
16
|
|
|
|
|
|
|
#pod as => $subname |
17
|
|
|
|
|
|
|
#pod }); |
18
|
|
|
|
|
|
|
#pod |
19
|
|
|
|
|
|
|
#pod =head1 DESCRIPTION |
20
|
|
|
|
|
|
|
#pod |
21
|
|
|
|
|
|
|
#pod This module makes it easy to install subroutines into packages without the |
22
|
|
|
|
|
|
|
#pod unsightly mess of C or typeglobs lying about where just anyone can |
23
|
|
|
|
|
|
|
#pod see them. |
24
|
|
|
|
|
|
|
#pod |
25
|
|
|
|
|
|
|
#pod =func install_sub |
26
|
|
|
|
|
|
|
#pod |
27
|
|
|
|
|
|
|
#pod Sub::Install::install_sub({ |
28
|
|
|
|
|
|
|
#pod code => \&subroutine, |
29
|
|
|
|
|
|
|
#pod into => "Finance::Shady", |
30
|
|
|
|
|
|
|
#pod as => 'launder', |
31
|
|
|
|
|
|
|
#pod }); |
32
|
|
|
|
|
|
|
#pod |
33
|
|
|
|
|
|
|
#pod This routine installs a given code reference into a package as a normal |
34
|
|
|
|
|
|
|
#pod subroutine. The above is equivalent to: |
35
|
|
|
|
|
|
|
#pod |
36
|
|
|
|
|
|
|
#pod no strict 'refs'; |
37
|
|
|
|
|
|
|
#pod *{"Finance::Shady" . '::' . "launder"} = \&subroutine; |
38
|
|
|
|
|
|
|
#pod |
39
|
|
|
|
|
|
|
#pod If C is not given, the sub is installed into the calling package. |
40
|
|
|
|
|
|
|
#pod |
41
|
|
|
|
|
|
|
#pod If C is not a code reference, it is looked for as an existing sub in the |
42
|
|
|
|
|
|
|
#pod package named in the C parameter. If C is not given, it will look |
43
|
|
|
|
|
|
|
#pod in the calling package. |
44
|
|
|
|
|
|
|
#pod |
45
|
|
|
|
|
|
|
#pod If C is not given, and if C is a name, C will default to C. |
46
|
|
|
|
|
|
|
#pod If C is not given, but if C is a code ref, Sub::Install will try to |
47
|
|
|
|
|
|
|
#pod find the name of the given code ref and use that as C. |
48
|
|
|
|
|
|
|
#pod |
49
|
|
|
|
|
|
|
#pod That means that this code: |
50
|
|
|
|
|
|
|
#pod |
51
|
|
|
|
|
|
|
#pod Sub::Install::install_sub({ |
52
|
|
|
|
|
|
|
#pod code => 'twitch', |
53
|
|
|
|
|
|
|
#pod from => 'Person::InPain', |
54
|
|
|
|
|
|
|
#pod into => 'Person::Teenager', |
55
|
|
|
|
|
|
|
#pod as => 'dance', |
56
|
|
|
|
|
|
|
#pod }); |
57
|
|
|
|
|
|
|
#pod |
58
|
|
|
|
|
|
|
#pod is the same as: |
59
|
|
|
|
|
|
|
#pod |
60
|
|
|
|
|
|
|
#pod package Person::Teenager; |
61
|
|
|
|
|
|
|
#pod |
62
|
|
|
|
|
|
|
#pod Sub::Install::install_sub({ |
63
|
|
|
|
|
|
|
#pod code => Person::InPain->can('twitch'), |
64
|
|
|
|
|
|
|
#pod as => 'dance', |
65
|
|
|
|
|
|
|
#pod }); |
66
|
|
|
|
|
|
|
#pod |
67
|
|
|
|
|
|
|
#pod =func reinstall_sub |
68
|
|
|
|
|
|
|
#pod |
69
|
|
|
|
|
|
|
#pod This routine behaves exactly like C>, but does not emit a |
70
|
|
|
|
|
|
|
#pod warning if warnings are on and the destination is already defined. |
71
|
|
|
|
|
|
|
#pod |
72
|
|
|
|
|
|
|
#pod =cut |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
sub _name_of_code { |
75
|
2
|
|
|
2
|
|
5
|
my ($code) = @_; |
76
|
2
|
|
|
|
|
19
|
require B; |
77
|
2
|
|
|
|
|
33
|
my $name = B::svref_2object($code)->GV->NAME; |
78
|
2
|
100
|
|
|
|
15
|
return $name unless $name =~ /\A__ANON__/; |
79
|
1
|
|
|
|
|
5
|
return; |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
# See also Params::Util, to which this code was donated. |
83
|
|
|
|
|
|
|
sub _CODELIKE { |
84
|
33
|
0
|
33
|
33
|
|
279
|
(Scalar::Util::reftype($_[0])||'') eq 'CODE' |
|
|
100
|
100
|
|
|
|
|
85
|
|
|
|
|
|
|
|| Scalar::Util::blessed($_[0]) |
86
|
|
|
|
|
|
|
&& (overload::Method($_[0],'&{}') ? $_[0] : undef); |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
# do the heavy lifting |
90
|
|
|
|
|
|
|
sub _build_public_installer { |
91
|
17
|
|
|
17
|
|
2088
|
my ($installer) = @_; |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
sub { |
94
|
34
|
|
|
34
|
|
22210
|
my ($arg) = @_; |
95
|
34
|
|
|
|
|
206
|
my ($calling_pkg) = caller(0); |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
# I'd rather use ||= but I'm whoring for Devel::Cover. |
98
|
34
|
100
|
|
|
|
87
|
for (qw(into from)) { $arg->{$_} = $calling_pkg unless $arg->{$_} } |
|
68
|
|
|
|
|
319
|
|
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
# This is the only absolutely required argument, in many cases. |
101
|
34
|
100
|
|
|
|
272
|
Carp::croak "named argument 'code' is not optional" unless $arg->{code}; |
102
|
|
|
|
|
|
|
|
103
|
33
|
100
|
|
|
|
86
|
if (_CODELIKE($arg->{code})) { |
104
|
26
|
|
100
|
|
|
77
|
$arg->{as} ||= _name_of_code($arg->{code}); |
105
|
|
|
|
|
|
|
} else { |
106
|
7
|
100
|
|
|
|
183
|
Carp::croak |
107
|
|
|
|
|
|
|
"couldn't find subroutine named $arg->{code} in package $arg->{from}" |
108
|
|
|
|
|
|
|
unless my $code = $arg->{from}->can($arg->{code}); |
109
|
|
|
|
|
|
|
|
110
|
6
|
100
|
|
|
|
26
|
$arg->{as} = $arg->{code} unless $arg->{as}; |
111
|
6
|
|
|
|
|
15
|
$arg->{code} = $code; |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
32
|
100
|
|
|
|
183
|
Carp::croak "couldn't determine name under which to install subroutine" |
115
|
|
|
|
|
|
|
unless $arg->{as}; |
116
|
|
|
|
|
|
|
|
117
|
31
|
|
|
|
|
148
|
$installer->(@$arg{qw(into as code) }); |
118
|
|
|
|
|
|
|
} |
119
|
17
|
|
|
|
|
115
|
} |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
# do the ugly work |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
my $_misc_warn_re; |
124
|
|
|
|
|
|
|
my $_redef_warn_re; |
125
|
|
|
|
|
|
|
BEGIN { |
126
|
8
|
|
|
8
|
|
36
|
$_misc_warn_re = qr/ |
127
|
|
|
|
|
|
|
Prototype\ mismatch:\ sub\ .+? | |
128
|
|
|
|
|
|
|
Constant subroutine .+? redefined |
129
|
|
|
|
|
|
|
/x; |
130
|
8
|
|
|
|
|
252
|
$_redef_warn_re = qr/Subroutine\ .+?\ redefined/x; |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
my $eow_re; |
134
|
8
|
|
|
8
|
|
3164
|
BEGIN { $eow_re = qr/ at .+? line \d+\.\Z/ }; |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
sub _do_with_warn { |
137
|
24
|
|
|
24
|
|
35
|
my ($arg) = @_; |
138
|
24
|
|
|
|
|
39
|
my $code = delete $arg->{code}; |
139
|
|
|
|
|
|
|
my $wants_code = sub { |
140
|
24
|
|
|
24
|
|
27
|
my $code = shift; |
141
|
|
|
|
|
|
|
sub { |
142
|
31
|
100
|
|
11
|
|
159
|
my $warn = $SIG{__WARN__} ? $SIG{__WARN__} : sub { warn @_ }; ## no critic |
|
0
|
|
|
|
|
0
|
|
143
|
|
|
|
|
|
|
local $SIG{__WARN__} = sub { |
144
|
9
|
|
|
9
|
|
424
|
my ($error) = @_; |
145
|
9
|
|
|
|
|
12
|
for (@{ $arg->{suppress} }) { |
|
9
|
|
|
|
|
23
|
|
146
|
4
|
100
|
|
|
|
42
|
return if $error =~ $_; |
147
|
|
|
|
|
|
|
} |
148
|
7
|
|
|
|
|
10
|
for (@{ $arg->{croak} }) { |
|
7
|
|
|
|
|
18
|
|
149
|
1
|
50
|
|
|
|
34
|
if (my ($base_error) = $error =~ /\A($_) $eow_re/x) { |
150
|
1
|
|
|
|
|
167
|
Carp::croak $base_error; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
} |
153
|
6
|
|
|
|
|
7
|
for (@{ $arg->{carp} }) { |
|
6
|
|
|
|
|
16
|
|
154
|
8
|
100
|
|
|
|
412
|
if (my ($base_error) = $error =~ /\A($_) $eow_re/x) { |
155
|
6
|
|
|
|
|
1086
|
return $warn->(Carp::shortmess $base_error); |
156
|
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
} |
158
|
0
|
|
0
|
|
|
0
|
($arg->{default} || $warn)->($error); |
159
|
31
|
|
|
|
|
181
|
}; |
160
|
31
|
|
|
|
|
75
|
$code->(@_); |
161
|
24
|
|
|
|
|
2823
|
}; |
162
|
24
|
|
|
|
|
129
|
}; |
163
|
24
|
100
|
|
|
|
73
|
return $wants_code->($code) if $code; |
164
|
16
|
|
|
|
|
39
|
return $wants_code; |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
sub _installer { |
168
|
|
|
|
|
|
|
sub { |
169
|
31
|
|
|
31
|
|
116
|
my ($pkg, $name, $code) = @_; |
170
|
8
|
|
|
8
|
|
42
|
no strict 'refs'; ## no critic ProhibitNoStrict |
|
8
|
|
|
|
|
13
|
|
|
8
|
|
|
|
|
1305
|
|
171
|
31
|
|
|
|
|
37
|
*{"$pkg\::$name"} = $code; |
|
31
|
|
|
|
|
177
|
|
172
|
30
|
|
|
|
|
559
|
return $code; |
173
|
|
|
|
|
|
|
} |
174
|
24
|
|
|
24
|
|
107
|
} |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
BEGIN { |
177
|
8
|
|
|
8
|
|
35
|
*_ignore_warnings = _do_with_warn({ |
178
|
|
|
|
|
|
|
carp => [ $_misc_warn_re, $_redef_warn_re ] |
179
|
|
|
|
|
|
|
}); |
180
|
|
|
|
|
|
|
|
181
|
8
|
|
|
|
|
25
|
*install_sub = _build_public_installer(_ignore_warnings(_installer)); |
182
|
|
|
|
|
|
|
|
183
|
8
|
|
|
|
|
94
|
*_carp_warnings = _do_with_warn({ |
184
|
|
|
|
|
|
|
carp => [ $_misc_warn_re ], |
185
|
|
|
|
|
|
|
suppress => [ $_redef_warn_re ], |
186
|
|
|
|
|
|
|
}); |
187
|
|
|
|
|
|
|
|
188
|
8
|
|
|
|
|
25
|
*reinstall_sub = _build_public_installer(_carp_warnings(_installer)); |
189
|
|
|
|
|
|
|
|
190
|
8
|
|
|
|
|
21
|
*_install_fatal = _do_with_warn({ |
191
|
|
|
|
|
|
|
code => _installer, |
192
|
|
|
|
|
|
|
croak => [ $_redef_warn_re ], |
193
|
|
|
|
|
|
|
}); |
194
|
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
#pod =func install_installers |
197
|
|
|
|
|
|
|
#pod |
198
|
|
|
|
|
|
|
#pod This routine is provided to allow Sub::Install compatibility with |
199
|
|
|
|
|
|
|
#pod Sub::Installer. It installs C and C methods into |
200
|
|
|
|
|
|
|
#pod the package named by its argument. |
201
|
|
|
|
|
|
|
#pod |
202
|
|
|
|
|
|
|
#pod Sub::Install::install_installers('Code::Builder'); # just for us, please |
203
|
|
|
|
|
|
|
#pod Code::Builder->install_sub({ name => $code_ref }); |
204
|
|
|
|
|
|
|
#pod |
205
|
|
|
|
|
|
|
#pod Sub::Install::install_installers('UNIVERSAL'); # feeling lucky, punk? |
206
|
|
|
|
|
|
|
#pod Anything::At::All->install_sub({ name => $code_ref }); |
207
|
|
|
|
|
|
|
#pod |
208
|
|
|
|
|
|
|
#pod The installed installers are similar, but not identical, to those provided by |
209
|
|
|
|
|
|
|
#pod Sub::Installer. They accept a single hash as an argument. The key/value pairs |
210
|
|
|
|
|
|
|
#pod are used as the C and C parameters to the C routine |
211
|
|
|
|
|
|
|
#pod detailed above. The package name on which the method is called is used as the |
212
|
|
|
|
|
|
|
#pod C parameter. |
213
|
|
|
|
|
|
|
#pod |
214
|
|
|
|
|
|
|
#pod Unlike Sub::Installer's C will not eval strings into code, but |
215
|
|
|
|
|
|
|
#pod will look for named code in the calling package. |
216
|
|
|
|
|
|
|
#pod |
217
|
|
|
|
|
|
|
#pod =cut |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
sub install_installers { |
220
|
2
|
|
|
2
|
1
|
14
|
my ($into) = @_; |
221
|
|
|
|
|
|
|
|
222
|
2
|
|
|
|
|
6
|
for my $method (qw(install_sub reinstall_sub)) { |
223
|
|
|
|
|
|
|
my $code = sub { |
224
|
6
|
|
|
6
|
|
5886
|
my ($package, $subs) = @_; |
225
|
6
|
|
|
|
|
25
|
my ($caller) = caller(0); |
226
|
6
|
|
|
|
|
10
|
my $return; |
227
|
6
|
|
|
|
|
19
|
for (my ($name, $sub) = %$subs) { |
228
|
12
|
|
|
|
|
83
|
$return = Sub::Install->can($method)->({ |
229
|
|
|
|
|
|
|
code => $sub, |
230
|
|
|
|
|
|
|
from => $caller, |
231
|
|
|
|
|
|
|
into => $package, |
232
|
|
|
|
|
|
|
as => $name |
233
|
|
|
|
|
|
|
}); |
234
|
|
|
|
|
|
|
} |
235
|
6
|
|
|
|
|
16
|
return $return; |
236
|
4
|
|
|
|
|
47
|
}; |
237
|
4
|
|
|
|
|
21
|
install_sub({ code => $code, into => $into, as => $method }); |
238
|
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
#pod =head1 EXPORTS |
242
|
|
|
|
|
|
|
#pod |
243
|
|
|
|
|
|
|
#pod Sub::Install exports C and C only if they are |
244
|
|
|
|
|
|
|
#pod requested. |
245
|
|
|
|
|
|
|
#pod |
246
|
|
|
|
|
|
|
#pod =head2 exporter |
247
|
|
|
|
|
|
|
#pod |
248
|
|
|
|
|
|
|
#pod Sub::Install has a never-exported subroutine called C, which is used |
249
|
|
|
|
|
|
|
#pod to implement its C routine. It takes a hashref of named arguments, |
250
|
|
|
|
|
|
|
#pod only one of which is currently recognize: C. This must be an arrayref |
251
|
|
|
|
|
|
|
#pod of subroutines to offer for export. |
252
|
|
|
|
|
|
|
#pod |
253
|
|
|
|
|
|
|
#pod This routine is mainly for Sub::Install's own consumption. Instead, consider |
254
|
|
|
|
|
|
|
#pod L. |
255
|
|
|
|
|
|
|
#pod |
256
|
|
|
|
|
|
|
#pod =cut |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
sub exporter { |
259
|
9
|
|
|
9
|
1
|
29
|
my ($arg) = @_; |
260
|
|
|
|
|
|
|
|
261
|
9
|
|
|
|
|
13
|
my %is_exported = map { $_ => undef } @{ $arg->{exports} }; |
|
17
|
|
|
|
|
63
|
|
|
9
|
|
|
|
|
24
|
|
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
sub { |
264
|
12
|
|
|
12
|
|
42828
|
my $class = shift; |
265
|
12
|
|
|
|
|
26
|
my $target = caller; |
266
|
12
|
|
|
|
|
156
|
for (@_) { |
267
|
5
|
100
|
|
|
|
210
|
Carp::croak "'$_' is not exported by $class" if !exists $is_exported{$_}; |
268
|
4
|
|
|
|
|
22
|
install_sub({ code => $_, from => $class, into => $target }); |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
} |
271
|
9
|
|
|
|
|
376
|
} |
272
|
|
|
|
|
|
|
|
273
|
8
|
|
|
8
|
|
35
|
BEGIN { *import = exporter({ exports => [ qw(install_sub reinstall_sub) ] }); } |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
#pod =head1 SEE ALSO |
276
|
|
|
|
|
|
|
#pod |
277
|
|
|
|
|
|
|
#pod =over |
278
|
|
|
|
|
|
|
#pod |
279
|
|
|
|
|
|
|
#pod =item L |
280
|
|
|
|
|
|
|
#pod |
281
|
|
|
|
|
|
|
#pod This module is (obviously) a reaction to Damian Conway's Sub::Installer, which |
282
|
|
|
|
|
|
|
#pod does the same thing, but does it by getting its greasy fingers all over |
283
|
|
|
|
|
|
|
#pod UNIVERSAL. I was really happy about the idea of making the installation of |
284
|
|
|
|
|
|
|
#pod coderefs less ugly, but I couldn't bring myself to replace the ugliness of |
285
|
|
|
|
|
|
|
#pod typeglobs and loosened strictures with the ugliness of UNIVERSAL methods. |
286
|
|
|
|
|
|
|
#pod |
287
|
|
|
|
|
|
|
#pod =item L |
288
|
|
|
|
|
|
|
#pod |
289
|
|
|
|
|
|
|
#pod This is a complete Exporter.pm replacement, built atop Sub::Install. |
290
|
|
|
|
|
|
|
#pod |
291
|
|
|
|
|
|
|
#pod =back |
292
|
|
|
|
|
|
|
#pod |
293
|
|
|
|
|
|
|
#pod =head1 EXTRA CREDITS |
294
|
|
|
|
|
|
|
#pod |
295
|
|
|
|
|
|
|
#pod Several of the tests are adapted from tests that shipped with Damian Conway's |
296
|
|
|
|
|
|
|
#pod Sub-Installer distribution. |
297
|
|
|
|
|
|
|
#pod |
298
|
|
|
|
|
|
|
#pod =cut |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
1; |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
__END__ |