line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#!/usr/bin/perl -c |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
package Symbol::Util; |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
=head1 NAME |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
Symbol::Util - Additional utils for Perl symbols manipulation |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
=head1 SYNOPSIS |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
use Symbol::Util ':all'; |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
my $caller = caller; |
14
|
|
|
|
|
|
|
*{ fetch_glob("${caller}::foo") } = sub { "this is foo" }; |
15
|
|
|
|
|
|
|
my $coderef = fetch_glob("${caller}::bar", "CODE"); |
16
|
|
|
|
|
|
|
sub baz { 42; } |
17
|
|
|
|
|
|
|
export_glob($caller, "baz"); |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
print join "\n", keys %{ stash("main") }; |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
delete_glob("${caller}::foo", "CODE"); |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
use constant PI => 3.14159265; |
24
|
|
|
|
|
|
|
delete_sub "PI"; # remove constant from public API |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
require YAML; |
27
|
|
|
|
|
|
|
export_package(__PACKAGE__, "YAML", "Dump"); # import YAML::Dump |
28
|
|
|
|
|
|
|
unexport_package(__PACKAGE, "YAML"); # remove imported symbols |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
no Symbol::Util; # clean all symbols imported from Symbol::Util |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
=head1 DESCRIPTION |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
This module provides a set of additional functions useful for Perl |
35
|
|
|
|
|
|
|
symbols manipulation. |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
All Perl symbols from the same package are organized as a stash. Each symbol |
38
|
|
|
|
|
|
|
(glob) contains one or more of following slots: C<SCALAR>, C<ARRAY>, C<HASH>, |
39
|
|
|
|
|
|
|
C<CODE>, C<IO>, C<FORMAT>. These slots are also accessible as standard |
40
|
|
|
|
|
|
|
variables or bare words. |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
The Perl symbols table is directly accessible with typeglob prefix but it can |
43
|
|
|
|
|
|
|
be difficult to read and problematic if strict mode is used. Also the access |
44
|
|
|
|
|
|
|
to stash, glob and one of its slot have different syntax notation. |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
C<stash> and C<fetch_glob> functions gets stash or glob without need to use |
47
|
|
|
|
|
|
|
C<no strict 'refs'>. |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
C<delete_glob> function allows to delete specific slot of |
50
|
|
|
|
|
|
|
symbol name without deleting others. |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
C<delete_sub> removes the symbol from class API. This symbol won't be |
53
|
|
|
|
|
|
|
available as an object method. |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
C<export_glob> function exports a glob to the target package. |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
C<export_package> works like L<Exporter> module and allows to export symbols |
58
|
|
|
|
|
|
|
from one package to other. |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
C<unexport_package> allows to delete previously exported symbols. |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
=for readme stop |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
=cut |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
67
|
8
|
|
|
8
|
|
293507
|
use 5.006; |
|
8
|
|
|
|
|
34
|
|
|
8
|
|
|
|
|
1303
|
|
68
|
|
|
|
|
|
|
|
69
|
8
|
|
|
8
|
|
61
|
use strict; |
|
8
|
|
|
|
|
22
|
|
|
8
|
|
|
|
|
518
|
|
70
|
8
|
|
|
8
|
|
74
|
use warnings; |
|
8
|
|
|
|
|
50
|
|
|
8
|
|
|
|
|
3498
|
|
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
our $VERSION = '0.0203'; |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
# Exported symbols $EXPORTED{$target}{$package}{$name}{$slot} = 1 |
76
|
|
|
|
|
|
|
my %EXPORTED; |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
=head1 USAGE |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
By default, the class does not export its symbols. |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
=over |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
=item use Symbol::Util ':all'; |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
Imports all available symbols. |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
=cut |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
sub import { |
92
|
17
|
|
|
17
|
|
16622
|
my ($package, @names) = @_; |
93
|
|
|
|
|
|
|
|
94
|
17
|
|
|
|
|
49
|
my $caller = caller(); |
95
|
|
|
|
|
|
|
|
96
|
17
|
100
|
|
|
|
31
|
my @EXPORT_OK = grep { /^[a-z]/ && !/^(?:import|unimport)$/ } keys %{ stash(__PACKAGE__) }; |
|
214
|
|
|
|
|
1725
|
|
|
17
|
|
|
|
|
150
|
|
97
|
17
|
|
|
|
|
99
|
my %EXPORT_TAGS = ( all => [ @EXPORT_OK ] ); |
98
|
|
|
|
|
|
|
|
99
|
17
|
|
|
|
|
139
|
return export_package($caller, $package, { |
100
|
|
|
|
|
|
|
OK => [ @EXPORT_OK ], |
101
|
|
|
|
|
|
|
TAGS => { %EXPORT_TAGS }, |
102
|
|
|
|
|
|
|
}, @names); |
103
|
|
|
|
|
|
|
}; |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
=item no Symbol::Util; |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
Deletes all imported symbols from caller name space. |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
=back |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
=cut |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
sub unimport { |
115
|
9
|
|
|
9
|
|
11297
|
my ($package) = @_; |
116
|
|
|
|
|
|
|
|
117
|
9
|
|
|
|
|
20
|
my $caller = caller(); |
118
|
|
|
|
|
|
|
|
119
|
9
|
|
|
|
|
23
|
return unexport_package($caller, $package); |
120
|
|
|
|
|
|
|
}; |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
=head1 FUNCTIONS |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
=over |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
=item stash( I<name> : Str ) : HashRef |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
Returns a reference to the stash for the specified name. If the stash does |
130
|
|
|
|
|
|
|
not already exist then it will be created. The name of the stash does not |
131
|
|
|
|
|
|
|
include the C<::> at the end. It is safe to use this function with |
132
|
|
|
|
|
|
|
C<use strict 'refs'>. |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
print join "\n", keys %{ stash("main") }; |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
=cut |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
sub stash ($) { |
139
|
8
|
|
|
8
|
|
56
|
no strict 'refs'; |
|
8
|
|
|
|
|
16
|
|
|
8
|
|
|
|
|
1022
|
|
140
|
61
|
|
|
61
|
1
|
114
|
return *{ $_[0] . '::' }{HASH}; |
|
61
|
|
|
|
|
342
|
|
141
|
|
|
|
|
|
|
}; |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
=item fetch_glob( I<name> : Str ) : GlobRef |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
=item fetch_glob( I<name> : Str, I<slot> : Str ) : Ref |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
Returns a reference to the glob for the specified symbol name. If the symbol |
149
|
|
|
|
|
|
|
does not already exist then it will be created. If the symbol name is |
150
|
|
|
|
|
|
|
unqualified then it will be looked up in the calling package. It is safe to |
151
|
|
|
|
|
|
|
use this function with C<use strict 'refs'>. |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
If the I<slot> argument is defined and this slot contains defined value, |
154
|
|
|
|
|
|
|
reference to this value is returned. The I<slot> argument can be one of the |
155
|
|
|
|
|
|
|
following strings: C<SCALAR>, C<ARRAY>, C<HASH>, C<CODE>, C<IO>, C<FORMAT>). |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
my $caller = caller; |
158
|
|
|
|
|
|
|
*{ fetch_glob("${caller}::foo") } = sub { "this is foo" }; |
159
|
|
|
|
|
|
|
my $coderef = fetch_glob("${caller}::foo", "CODE"); |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
=cut |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
sub fetch_glob ($;$) { |
164
|
168
|
|
|
168
|
1
|
2931
|
my ($name, $slot) = @_; |
165
|
|
|
|
|
|
|
|
166
|
168
|
100
|
|
|
|
417
|
$name = caller() . "::$name" unless $name =~ /::/; |
167
|
|
|
|
|
|
|
|
168
|
8
|
|
|
8
|
|
45
|
no strict 'refs'; |
|
8
|
|
|
|
|
16
|
|
|
8
|
|
|
|
|
2378
|
|
169
|
|
|
|
|
|
|
|
170
|
168
|
100
|
|
|
|
331
|
if (defined $slot) { |
171
|
96
|
100
|
100
|
|
|
244
|
return if $slot eq 'SCALAR' and not defined ${ *{ $name }{SCALAR} }; |
|
5
|
|
|
|
|
6
|
|
|
5
|
|
|
|
|
44
|
|
172
|
94
|
|
|
|
|
188
|
return *{ $name }{$slot}; |
|
94
|
|
|
|
|
510
|
|
173
|
|
|
|
|
|
|
}; |
174
|
|
|
|
|
|
|
|
175
|
72
|
|
|
|
|
81
|
return \*{ $name }; |
|
72
|
|
|
|
|
332
|
|
176
|
|
|
|
|
|
|
}; |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
=item list_glob_slots( I<name> ) : Maybe[Array] |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
Returns a list of slot names for glob with specified I<name> which contain |
182
|
|
|
|
|
|
|
defined value. If the glob is undefined, the C<undef> value is returned. If |
183
|
|
|
|
|
|
|
the glob is defined and has no defined slots, the empty list is returned. |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
The C<SCALAR> slot is used only if it contains defined value. |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
my $foo = 42; |
188
|
|
|
|
|
|
|
my @foo = (1, 2); |
189
|
|
|
|
|
|
|
sub foo { 1; }; |
190
|
|
|
|
|
|
|
print join ",", list_glob_slots("foo"); # SCALAR,ARRAY,CODE |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
=cut |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
sub list_glob_slots ($) { |
195
|
45
|
|
|
45
|
1
|
3183
|
my ($name) = @_; |
196
|
|
|
|
|
|
|
|
197
|
45
|
100
|
|
|
|
150
|
$name = caller() . "::$name" unless $name =~ /::/; |
198
|
|
|
|
|
|
|
|
199
|
8
|
|
|
8
|
|
54
|
no strict 'refs'; |
|
8
|
|
|
|
|
15
|
|
|
8
|
|
|
|
|
2384
|
|
200
|
|
|
|
|
|
|
|
201
|
45
|
100
|
|
|
|
54
|
return if not defined *{ $name }; |
|
45
|
|
|
|
|
184
|
|
202
|
|
|
|
|
|
|
|
203
|
44
|
|
|
|
|
66
|
my @slots; |
204
|
|
|
|
|
|
|
|
205
|
44
|
|
|
|
|
210
|
push @slots, 'SCALAR' |
206
|
44
|
100
|
66
|
|
|
54
|
if defined *{ $name }{SCALAR} and defined ${ *{ $name }{SCALAR} }; |
|
44
|
|
|
|
|
52
|
|
|
44
|
|
|
|
|
253
|
|
207
|
|
|
|
|
|
|
|
208
|
44
|
|
|
|
|
96
|
foreach my $slot (qw( ARRAY HASH CODE IO )) { |
209
|
176
|
100
|
|
|
|
179
|
push @slots, $slot if defined *{ $name }{$slot}; |
|
176
|
|
|
|
|
763
|
|
210
|
|
|
|
|
|
|
}; |
211
|
|
|
|
|
|
|
|
212
|
44
|
|
|
|
|
135
|
return @slots; |
213
|
|
|
|
|
|
|
}; |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
=item export_glob( I<target>, I<name> : Str ) : GlobRef |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
=item export_glob( I<target>, I<name> : Str, I<slots> : Array ) : Ref |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
Exports a glob I<name> to the I<target> package. Optionally exports only |
221
|
|
|
|
|
|
|
specified slots of the glob. |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
sub my_function { ... }; |
224
|
|
|
|
|
|
|
sub import { |
225
|
|
|
|
|
|
|
my $caller = caller; |
226
|
|
|
|
|
|
|
export_glob($caller, "my_function"); |
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
=cut |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
sub export_glob ($$;@) { |
232
|
48
|
|
|
48
|
1
|
9221
|
my ($target, $name, @slots) = @_; |
233
|
|
|
|
|
|
|
|
234
|
48
|
100
|
|
|
|
177
|
$name = caller() . "::$name" unless $name =~ /::/; |
235
|
48
|
|
|
|
|
268
|
(my $subname = $name) =~ s/^(.*):://; |
236
|
|
|
|
|
|
|
|
237
|
48
|
100
|
|
|
|
126
|
@slots = qw( SCALAR ARRAY HASH CODE IO ) unless @slots; |
238
|
|
|
|
|
|
|
|
239
|
8
|
|
|
8
|
|
51
|
no strict 'refs'; |
|
8
|
|
|
|
|
16
|
|
|
8
|
|
|
|
|
20237
|
|
240
|
|
|
|
|
|
|
|
241
|
48
|
100
|
|
|
|
80
|
return if not defined *{ $name }; |
|
48
|
|
|
|
|
224
|
|
242
|
|
|
|
|
|
|
|
243
|
47
|
|
|
|
|
113
|
my $targetname = "${target}::$subname"; |
244
|
|
|
|
|
|
|
|
245
|
47
|
|
|
|
|
57
|
my $defined; |
246
|
47
|
|
|
|
|
73
|
foreach my $slot (@slots) { |
247
|
51
|
100
|
100
|
|
|
147
|
next if $slot eq 'SCALAR' and not defined ${ *{ $name }{$slot} }; |
|
5
|
|
|
|
|
8
|
|
|
5
|
|
|
|
|
35
|
|
248
|
50
|
100
|
|
|
|
107
|
next if not defined *{ $name }{$slot}; |
|
50
|
|
|
|
|
896
|
|
249
|
46
|
|
|
|
|
71
|
*{ $targetname } = *{ $name }{$slot}; |
|
46
|
|
|
|
|
220
|
|
|
46
|
|
|
|
|
123
|
|
250
|
46
|
|
|
|
|
300
|
$defined = 1; |
251
|
|
|
|
|
|
|
}; |
252
|
|
|
|
|
|
|
|
253
|
47
|
100
|
|
|
|
103
|
return $defined ? \*{ $targetname } : undef; |
|
45
|
|
|
|
|
243
|
|
254
|
|
|
|
|
|
|
}; |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
=item delete_glob( I<name> : Str, I<slots> : Array[Str] ) : Maybe[GlobRef] |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
Deletes the specified symbol name if I<slots> are not specified, or deletes |
260
|
|
|
|
|
|
|
the specified slots in the symbol name (could be one or more of the following |
261
|
|
|
|
|
|
|
strings: C<SCALAR>, C<ARRAY>, C<HASH>, C<CODE>, C<IO>, C<FORMAT>). |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
Function returns the glob reference if there are any slots defined. |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
our $FOO = 1; |
266
|
|
|
|
|
|
|
sub FOO { "bar" }; |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
delete_glob("FOO", "CODE"); |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
print $FOO; # prints "1" |
271
|
|
|
|
|
|
|
FOO(); # error: sub not found |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
=cut |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
sub delete_glob ($;@) { |
276
|
12
|
|
|
12
|
1
|
15451
|
my ($name, @slots) = @_; |
277
|
|
|
|
|
|
|
|
278
|
12
|
100
|
|
|
|
57
|
$name = caller() . "::$name" unless $name =~ /::/; |
279
|
12
|
|
|
|
|
199
|
$name =~ /^(.*)::([^:]*)/; |
280
|
12
|
|
|
|
|
47
|
my ($package, $subname) = ($1, $2); ## no critic qw(ProhibitCaptureWithoutTest) |
281
|
|
|
|
|
|
|
|
282
|
12
|
|
|
|
|
34
|
my $stash = stash($package); |
283
|
|
|
|
|
|
|
|
284
|
12
|
100
|
|
|
|
38
|
if (@slots) { |
285
|
10
|
|
|
|
|
21
|
my %delete = map { $_ => 1 } @slots; |
|
11
|
|
|
|
|
41
|
|
286
|
10
|
|
|
|
|
18
|
my %backup; |
287
|
|
|
|
|
|
|
|
288
|
10
|
|
|
|
|
24
|
foreach my $slot (list_glob_slots($name)) { |
289
|
33
|
100
|
|
|
|
106
|
$backup{$slot} = fetch_glob($name, $slot) |
290
|
|
|
|
|
|
|
if not $delete{$slot}; |
291
|
|
|
|
|
|
|
}; |
292
|
|
|
|
|
|
|
|
293
|
10
|
|
|
|
|
64
|
undef $stash->{$subname}; |
294
|
|
|
|
|
|
|
|
295
|
10
|
|
|
|
|
28
|
foreach my $slot (keys %backup) { |
296
|
22
|
|
|
|
|
31
|
*{ fetch_glob($name) } = $backup{$slot}; |
|
22
|
|
|
|
|
38
|
|
297
|
|
|
|
|
|
|
}; |
298
|
|
|
|
|
|
|
|
299
|
10
|
|
|
|
|
25
|
return fetch_glob($name); |
300
|
|
|
|
|
|
|
} |
301
|
|
|
|
|
|
|
else { |
302
|
|
|
|
|
|
|
# delete all slots |
303
|
2
|
|
|
|
|
20
|
undef $stash->{$subname}; |
304
|
|
|
|
|
|
|
}; |
305
|
|
|
|
|
|
|
|
306
|
2
|
|
|
|
|
17
|
return; |
307
|
|
|
|
|
|
|
}; |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
=item delete_sub( I<name> : Str ) : Maybe[GlobRef] |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
Deletes (or hides) the specified subroutine name from class API. It means |
313
|
|
|
|
|
|
|
that this subroutine will be no longer available as a class method. The |
314
|
|
|
|
|
|
|
purpose of this function is the same as L<namespace::clean> pragma has: it |
315
|
|
|
|
|
|
|
cleans a package's namespace from unwanted subroutines. Function doesn't |
316
|
|
|
|
|
|
|
delete other slots than C<CODE> slot of the glob. |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
Function returns the glob reference if there are any other slots still defined |
319
|
|
|
|
|
|
|
than <CODE> slot. |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
package My::Class; |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
use constant PI => 3.14159265; |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
use Symbol::Util 'delete_sub'; |
326
|
|
|
|
|
|
|
delete_sub "PI"; # remove constant from public API |
327
|
|
|
|
|
|
|
no Symbol::Util; # remove also Symbol::Util::* from public API |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
sub area { |
330
|
|
|
|
|
|
|
my ($self, $r) = @_; |
331
|
|
|
|
|
|
|
return PI * $r ** 2; |
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
print My::Class->area(2); # prints 12.5663706 |
335
|
|
|
|
|
|
|
print My::Class->PI; # Can't locate object method |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
=cut |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
sub delete_sub ($) { |
340
|
31
|
|
|
31
|
1
|
11018
|
my ($name) = @_; |
341
|
|
|
|
|
|
|
|
342
|
31
|
100
|
|
|
|
669
|
$name = caller() . "::$name" unless $name =~ /::/; |
343
|
31
|
|
|
|
|
132
|
$name =~ /^(.*)::([^:]*)/; |
344
|
31
|
|
|
|
|
96
|
my ($package, $subname) = ($1, $2); ## no critic qw(ProhibitCaptureWithoutTest) |
345
|
|
|
|
|
|
|
|
346
|
31
|
100
|
|
|
|
80
|
return if not defined fetch_glob($name, 'CODE'); |
347
|
|
|
|
|
|
|
|
348
|
30
|
|
|
|
|
73
|
my $stash = stash($package); |
349
|
|
|
|
|
|
|
|
350
|
30
|
|
|
|
|
41
|
my %backup; |
351
|
|
|
|
|
|
|
|
352
|
30
|
|
|
|
|
69
|
foreach my $slot (list_glob_slots($name)) { |
353
|
34
|
|
|
|
|
72
|
$backup{$slot} = fetch_glob($name, $slot); |
354
|
|
|
|
|
|
|
}; |
355
|
|
|
|
|
|
|
|
356
|
30
|
|
|
|
|
56
|
*{ fetch_glob($name) } = $backup{CODE}; |
|
30
|
|
|
|
|
50
|
|
357
|
30
|
|
|
|
|
62
|
delete $backup{CODE}; |
358
|
|
|
|
|
|
|
|
359
|
30
|
|
|
|
|
77
|
delete $stash->{$subname}; |
360
|
|
|
|
|
|
|
|
361
|
30
|
|
|
|
|
84
|
foreach my $slot (keys %backup) { |
362
|
4
|
|
|
|
|
5
|
*{ fetch_glob($name) } = $backup{$slot}; |
|
4
|
|
|
|
|
7
|
|
363
|
|
|
|
|
|
|
}; |
364
|
|
|
|
|
|
|
|
365
|
30
|
100
|
|
|
|
156
|
return %backup ? fetch_glob($name) : undef; |
366
|
|
|
|
|
|
|
}; |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
=item export_package( I<target> : Str, I<package> : Str, I<names> : Array[Str] ) : Bool |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
=item export_package( I<target> : Str, I<package> : Str, I<spec> : HashRef, I<names> : Array[Str] ) : Bool |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
Exports symbols from I<package> to I<target>. If I<spec> is defined as hash |
374
|
|
|
|
|
|
|
reference, it contains the specification for exporter. Otherwise the standard |
375
|
|
|
|
|
|
|
global variables of I<package> are used (C<@EXPORT>, C<@EXPORT_OK> and |
376
|
|
|
|
|
|
|
C<%EXPORT_TAGS>) to build the specification for exporter. The optional list |
377
|
|
|
|
|
|
|
of I<names> defines an import list. |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
The I<spec> is a reference to hash with following keys: |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
=over |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
=item EXPORT |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
Contains the list of default imports. It is the same as C<@EXPORT> variable. |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
=item OK |
388
|
|
|
|
|
|
|
|
389
|
|
|
|
|
|
|
Contains the list of allowed imports. It is the same as C<@EXPORT_OK> |
390
|
|
|
|
|
|
|
variable. |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
=item TAGS |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
Contains the hash with tags. It is the same as C<%EXPORT_TAGS> variable. |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
=back |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
See L<Exporter> documentation for explanation of these global variables and |
399
|
|
|
|
|
|
|
list of I<names>. |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
The C<export_package> function can export symbols from an external package to |
402
|
|
|
|
|
|
|
an external package. This function can also be used as a helper in C<import> |
403
|
|
|
|
|
|
|
method. |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
package My::Package; |
406
|
|
|
|
|
|
|
sub myfunc { }; |
407
|
|
|
|
|
|
|
sub import { |
408
|
|
|
|
|
|
|
my ($package, @names) = @_; |
409
|
|
|
|
|
|
|
my $caller = caller(); |
410
|
|
|
|
|
|
|
return export_package($caller, $package, { |
411
|
|
|
|
|
|
|
OK => [ qw( myfunc ) ], |
412
|
|
|
|
|
|
|
}, @names); |
413
|
|
|
|
|
|
|
}; |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
All exported symbols are tracked and later can be removed with |
416
|
|
|
|
|
|
|
C<unexport_package> function. |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
The function returns true value if there were no errors. |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
=cut |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
sub export_package ($$@) { |
423
|
33
|
|
|
33
|
1
|
36926
|
my ($target, $package, @args) = @_; |
424
|
|
|
|
|
|
|
|
425
|
33
|
100
|
|
|
|
161
|
my $spec = ref $args[0] eq 'HASH' ? shift @args : { |
426
|
|
|
|
|
|
|
EXPORT => fetch_glob("${package}::EXPORT", "ARRAY"), |
427
|
|
|
|
|
|
|
OK => fetch_glob("${package}::EXPORT_OK", "ARRAY"), |
428
|
|
|
|
|
|
|
TAGS => fetch_glob("${package}::EXPORT_TAGS", "HASH"), |
429
|
|
|
|
|
|
|
}; |
430
|
|
|
|
|
|
|
|
431
|
33
|
|
|
|
|
81
|
my @names = @args; |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
# support: use Package 3.14 qw(); |
434
|
33
|
100
|
100
|
|
|
227
|
return 1 if @names == 1 and $names[0] eq ''; |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
# default exports on empty list or if first element is negation |
437
|
32
|
100
|
66
|
|
|
280
|
unshift @names, ":DEFAULT" if not @names or @names and $names[0] =~ /^!/; |
|
|
|
66
|
|
|
|
|
438
|
|
|
|
|
|
|
|
439
|
32
|
100
|
100
|
|
|
203
|
my @export = ref ($spec->{EXPORT} || '') eq 'ARRAY' ? @{ $spec->{EXPORT} } : (); |
|
9
|
|
|
|
|
30
|
|
440
|
32
|
100
|
100
|
|
|
183
|
my @export_ok = ref ($spec->{OK} || '') eq 'ARRAY' ? @{ $spec->{OK} } : (); |
|
22
|
|
|
|
|
137
|
|
441
|
32
|
100
|
100
|
|
|
196
|
my %export_tags = ref ($spec->{TAGS} || '') eq 'HASH' ? %{ $spec->{TAGS} } : (); |
|
21
|
|
|
|
|
75
|
|
442
|
|
|
|
|
|
|
|
443
|
32
|
|
|
|
|
75
|
my %export = map { $_ => 1 } @export; |
|
16
|
|
|
|
|
59
|
|
444
|
32
|
|
|
|
|
69
|
my %export_ok = map { $_ => 1 } @export_ok; |
|
144
|
|
|
|
|
306
|
|
445
|
|
|
|
|
|
|
|
446
|
32
|
|
|
|
|
136
|
my %names; |
447
|
|
|
|
|
|
|
|
448
|
32
|
|
|
|
|
129
|
while (my $name = shift @names) { |
449
|
62
|
100
|
100
|
|
|
569
|
if ($name =~ m{^/(.*)/$}) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
450
|
1
|
|
|
|
|
4
|
my $pattern = $1; |
451
|
1
|
|
|
|
|
3
|
$names{$_} = 1 foreach grep { /$pattern/ } (@export, @export_ok); |
|
2
|
|
|
|
|
32
|
|
452
|
|
|
|
|
|
|
} |
453
|
|
|
|
|
|
|
elsif ($name =~ m{^!/(.*)/$}) { |
454
|
1
|
|
|
|
|
2
|
my $pattern = $1; |
455
|
1
|
|
|
|
|
4
|
%names = map { $_ => 1 } grep { ! /$pattern/ } keys %names; |
|
1
|
|
|
|
|
8
|
|
|
2
|
|
|
|
|
26
|
|
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
elsif ($name =~ /^(!?):DEFAULT$/) { |
458
|
6
|
|
|
|
|
19
|
my $neg = $1; |
459
|
6
|
|
|
|
|
12
|
unshift @names, map { "${neg}$_" } @export; |
|
9
|
|
|
|
|
38
|
|
460
|
|
|
|
|
|
|
} |
461
|
|
|
|
|
|
|
elsif ($name =~ /^(!?):(.*)$/) { |
462
|
6
|
|
|
|
|
26
|
my ($neg, $tag) = ($1, $2); |
463
|
6
|
100
|
|
|
|
22
|
if (defined $export_tags{$tag}) { |
464
|
5
|
|
|
|
|
12
|
unshift @names, map { "${neg}$_" } @{ $export_tags{$tag} }; |
|
12
|
|
|
|
|
49
|
|
|
5
|
|
|
|
|
10
|
|
465
|
|
|
|
|
|
|
} |
466
|
|
|
|
|
|
|
else { |
467
|
1
|
|
|
|
|
8
|
require Carp; |
468
|
1
|
|
|
|
|
151
|
Carp::croak("$name is not a tag of the $package module"); |
469
|
|
|
|
|
|
|
}; |
470
|
|
|
|
|
|
|
} |
471
|
|
|
|
|
|
|
elsif ($name =~ /^!(.*)$/) { |
472
|
2
|
|
|
|
|
7
|
$name = $1; |
473
|
2
|
|
|
|
|
10
|
delete $names{$name}; |
474
|
|
|
|
|
|
|
} |
475
|
|
|
|
|
|
|
elsif (defined $export_ok{$name} or defined $export{$name}) { |
476
|
44
|
|
|
|
|
208
|
$names{$name} = 1; |
477
|
|
|
|
|
|
|
} |
478
|
|
|
|
|
|
|
else { |
479
|
2
|
|
|
|
|
16
|
require Carp; |
480
|
2
|
|
|
|
|
350
|
Carp::croak("$name is not exported by the $package module"); |
481
|
|
|
|
|
|
|
}; |
482
|
|
|
|
|
|
|
}; |
483
|
|
|
|
|
|
|
|
484
|
29
|
|
|
|
|
102
|
foreach my $name (keys %names) { |
485
|
42
|
|
|
|
|
72
|
my $type = ''; |
486
|
42
|
100
|
|
|
|
165
|
if ($name =~ s/^(\W)//) { |
487
|
6
|
|
|
|
|
15
|
$type = $1; |
488
|
|
|
|
|
|
|
}; |
489
|
|
|
|
|
|
|
|
490
|
42
|
|
|
|
|
52
|
my @slots; |
491
|
42
|
100
|
100
|
|
|
212
|
if ($type eq '&' or $type eq '') { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
492
|
37
|
|
|
|
|
74
|
push @slots, 'CODE'; |
493
|
|
|
|
|
|
|
} |
494
|
|
|
|
|
|
|
elsif ($type eq '$') { |
495
|
1
|
|
|
|
|
3
|
push @slots, 'SCALAR'; |
496
|
|
|
|
|
|
|
} |
497
|
|
|
|
|
|
|
elsif ($type eq '@') { |
498
|
1
|
|
|
|
|
2
|
push @slots, 'ARRAY'; |
499
|
|
|
|
|
|
|
} |
500
|
|
|
|
|
|
|
elsif ($type eq '%') { |
501
|
1
|
|
|
|
|
3
|
push @slots, 'HASH'; |
502
|
|
|
|
|
|
|
} |
503
|
|
|
|
|
|
|
elsif ($type eq '*') { |
504
|
1
|
|
|
|
|
3
|
push @slots, 'IO'; |
505
|
|
|
|
|
|
|
} |
506
|
|
|
|
|
|
|
else { |
507
|
1
|
|
|
|
|
9
|
require Carp; |
508
|
1
|
|
|
|
|
150
|
Carp::croak("Can't export symbol $type$name"); |
509
|
|
|
|
|
|
|
}; |
510
|
41
|
|
|
|
|
74
|
foreach my $slot (@slots) { |
511
|
41
|
50
|
|
|
|
157
|
if (defined export_glob($target, "${package}::$name", $slot)) { |
512
|
41
|
|
|
|
|
299
|
$EXPORTED{$target}{$package}{$name}{$slot} = 1; |
513
|
|
|
|
|
|
|
}; |
514
|
|
|
|
|
|
|
}; |
515
|
|
|
|
|
|
|
}; |
516
|
|
|
|
|
|
|
|
517
|
28
|
|
|
|
|
594
|
return 1; |
518
|
|
|
|
|
|
|
}; |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
|
521
|
|
|
|
|
|
|
=item unexport_package( I<target> : Str, I<package> : Str ) : Bool |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
Deletes symbols previously exported from I<package> to I<target> with |
524
|
|
|
|
|
|
|
C<export_package> function. If the symbol was C<CODE> reference it is deleted |
525
|
|
|
|
|
|
|
with C<delete_sub> function. Otherwise it is deleted with C<delete_glob> |
526
|
|
|
|
|
|
|
function with proper slot as an argument. |
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
Deleting with C<delete_sub> function means that this symbol is not available |
529
|
|
|
|
|
|
|
via class API as an object method. |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
require YAML; |
532
|
|
|
|
|
|
|
export_package(__PACKAGE__, "YAML", "Dump"); |
533
|
|
|
|
|
|
|
unexport_package(__PACKAGE__, "YAML"); |
534
|
|
|
|
|
|
|
print Dump @INC; # OK |
535
|
|
|
|
|
|
|
__PACKAGE__->Dump; # Can't locate object method |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
This function can be used as a helper in C<unimport> method. |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
package My::Package; |
540
|
|
|
|
|
|
|
sub unimport { |
541
|
|
|
|
|
|
|
my ($package, @names) = @_; |
542
|
|
|
|
|
|
|
my $caller = caller(); |
543
|
|
|
|
|
|
|
return unexport_package($caller, $package); |
544
|
|
|
|
|
|
|
}; |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
package main; |
547
|
|
|
|
|
|
|
use My::Package qw(something); |
548
|
|
|
|
|
|
|
no My::Package; |
549
|
|
|
|
|
|
|
main->something; # Can't locate object method |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
The function returns true value if there were no errors. |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
=back |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
=cut |
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
sub unexport_package ($$) { |
558
|
19
|
|
|
19
|
1
|
33670
|
my ($target, $package) = @_; |
559
|
|
|
|
|
|
|
|
560
|
19
|
50
|
|
|
|
105
|
if (defined $EXPORTED{$target}{$package}) { |
561
|
19
|
|
|
|
|
32
|
foreach my $name (keys %{ $EXPORTED{$target}{$package} }) { |
|
19
|
|
|
|
|
90
|
|
562
|
|
|
|
|
|
|
# CODE slot have to be the last one |
563
|
29
|
|
|
|
|
52
|
foreach my $slot ( qw( SCALAR ARRAY HASH IO CODE ) ) { |
564
|
145
|
100
|
|
|
|
419
|
next unless exists $EXPORTED{$target}{$package}{$name}{$slot}; |
565
|
32
|
100
|
|
|
|
78
|
if ($slot eq 'CODE') { |
566
|
28
|
|
|
|
|
101
|
delete_sub("${target}::$name"); |
567
|
|
|
|
|
|
|
} |
568
|
|
|
|
|
|
|
else { |
569
|
4
|
|
|
|
|
16
|
delete_glob("${target}::$name", $slot); |
570
|
|
|
|
|
|
|
}; |
571
|
|
|
|
|
|
|
}; |
572
|
|
|
|
|
|
|
}; |
573
|
19
|
|
|
|
|
179
|
delete $EXPORTED{$target}{$package}; |
574
|
|
|
|
|
|
|
}; |
575
|
|
|
|
|
|
|
|
576
|
19
|
|
|
|
|
92
|
return 1; |
577
|
|
|
|
|
|
|
}; |
578
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
1; |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
=begin umlwiki |
584
|
|
|
|
|
|
|
|
585
|
|
|
|
|
|
|
= Class Diagram = |
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
[ <<utility>> |
588
|
|
|
|
|
|
|
Symbol::Util |
589
|
|
|
|
|
|
|
------------------------------------------------------------------ |
590
|
|
|
|
|
|
|
------------------------------------------------------------------ |
591
|
|
|
|
|
|
|
stash( name : Str ) : HashRef |
592
|
|
|
|
|
|
|
fetch_glob( name : Str ) : GlobRef |
593
|
|
|
|
|
|
|
fetch_glob( name : Str, slot : Str ) : Ref |
594
|
|
|
|
|
|
|
list_glob_slots( name : Str ) : Array |
595
|
|
|
|
|
|
|
export_glob( package : Str, name : Str ) : GlobRef |
596
|
|
|
|
|
|
|
export_glob( package : Str, name : Str, slots : Array[Str] ) : GlobRef |
597
|
|
|
|
|
|
|
delete_glob( name : Str, slots : Array[Str] ) : GlobRef |
598
|
|
|
|
|
|
|
delete_sub( name : Str ) : GlobRef |
599
|
|
|
|
|
|
|
export_package( target : Str, package : Str, names : Array[Str] ) : Bool |
600
|
|
|
|
|
|
|
export_package( target : Str, package : Str, spec : HashRef, names : Array[Str] ) : Bool |
601
|
|
|
|
|
|
|
unexport_package( target : Str, package : Str ) : Bool |
602
|
|
|
|
|
|
|
] |
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
=end umlwiki |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
=head1 SEE ALSO |
607
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
L<Symbol>, L<Sub::Delete>, L<namespace::clean>, L<Exporter>. |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
=head1 BUGS |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
C<fetch_glob> returns C<undef> value if C<SCALAR> slot contains C<undef> value. |
613
|
|
|
|
|
|
|
|
614
|
|
|
|
|
|
|
C<delete_glob> and C<delete_sub> delete C<SCALAR> slot if it exists and |
615
|
|
|
|
|
|
|
contains C<undef> value. |
616
|
|
|
|
|
|
|
|
617
|
|
|
|
|
|
|
C<delete_glob> and C<delete_sub> always delete C<FORMAT> slot. |
618
|
|
|
|
|
|
|
|
619
|
|
|
|
|
|
|
If you find the bug or want to implement new features, please report it at |
620
|
|
|
|
|
|
|
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Symbol-Util> |
621
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
=for readme continue |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
=head1 AUTHOR |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
Piotr Roszatycki <dexter@cpan.org> |
627
|
|
|
|
|
|
|
|
628
|
|
|
|
|
|
|
=head1 LICENSE |
629
|
|
|
|
|
|
|
|
630
|
|
|
|
|
|
|
Copyright (c) 2009, 2012 Piotr Roszatycki <dexter@cpan.org>. |
631
|
|
|
|
|
|
|
|
632
|
|
|
|
|
|
|
This is free software; you can redistribute it and/or modify it under |
633
|
|
|
|
|
|
|
the same terms as perl itself. |
634
|
|
|
|
|
|
|
|
635
|
|
|
|
|
|
|
See L<http://dev.perl.org/licenses/artistic.html> |