line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Package::Stash::PP; |
2
|
24
|
|
|
24
|
|
14941
|
use strict; |
|
24
|
|
|
|
|
51
|
|
|
24
|
|
|
|
|
637
|
|
3
|
24
|
|
|
24
|
|
108
|
use warnings; |
|
24
|
|
|
|
|
43
|
|
|
24
|
|
|
|
|
1028
|
|
4
|
|
|
|
|
|
|
# ABSTRACT: Pure perl implementation of the Package::Stash API |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
our $VERSION = '0.40'; |
7
|
|
|
|
|
|
|
|
8
|
24
|
|
|
24
|
|
144
|
use B; |
|
24
|
|
|
|
|
42
|
|
|
24
|
|
|
|
|
1126
|
|
9
|
24
|
|
|
24
|
|
129
|
use Carp qw(confess); |
|
24
|
|
|
|
|
45
|
|
|
24
|
|
|
|
|
1133
|
|
10
|
24
|
|
|
24
|
|
157
|
use Scalar::Util qw(blessed reftype weaken); |
|
24
|
|
|
|
|
39
|
|
|
24
|
|
|
|
|
1168
|
|
11
|
24
|
|
|
24
|
|
10004
|
use Symbol; |
|
24
|
|
|
|
|
16568
|
|
|
24
|
|
|
|
|
1489
|
|
12
|
|
|
|
|
|
|
# before 5.12, assigning to the ISA glob would make it lose its magical ->isa |
13
|
|
|
|
|
|
|
# powers |
14
|
24
|
|
|
24
|
|
155
|
use constant BROKEN_ISA_ASSIGNMENT => ($] < 5.012); |
|
24
|
|
|
|
|
41
|
|
|
24
|
|
|
|
|
1575
|
|
15
|
|
|
|
|
|
|
# before 5.10, stashes don't ever seem to drop to a refcount of zero, so |
16
|
|
|
|
|
|
|
# weakening them isn't helpful |
17
|
24
|
|
|
24
|
|
125
|
use constant BROKEN_WEAK_STASH => ($] < 5.010); |
|
24
|
|
|
|
|
40
|
|
|
24
|
|
|
|
|
1107
|
|
18
|
|
|
|
|
|
|
# before 5.10, the scalar slot was always treated as existing if the |
19
|
|
|
|
|
|
|
# glob existed |
20
|
24
|
|
|
24
|
|
119
|
use constant BROKEN_SCALAR_INITIALIZATION => ($] < 5.010); |
|
24
|
|
|
|
|
37
|
|
|
24
|
|
|
|
|
978
|
|
21
|
|
|
|
|
|
|
# add_method on anon stashes triggers rt.perl #1804 otherwise |
22
|
|
|
|
|
|
|
# fixed in perl commit v5.13.3-70-g0fe688f |
23
|
24
|
|
|
24
|
|
119
|
use constant BROKEN_GLOB_ASSIGNMENT => ($] < 5.013004); |
|
24
|
|
|
|
|
43
|
|
|
24
|
|
|
|
|
1373
|
|
24
|
|
|
|
|
|
|
# pre-5.10, ->isa lookups were cached in the ::ISA::CACHE:: slot |
25
|
24
|
|
|
24
|
|
114
|
use constant HAS_ISA_CACHE => ($] < 5.010); |
|
24
|
|
|
|
|
41
|
|
|
24
|
|
|
|
|
6698
|
|
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
#pod =head1 SYNOPSIS |
28
|
|
|
|
|
|
|
#pod |
29
|
|
|
|
|
|
|
#pod use Package::Stash; |
30
|
|
|
|
|
|
|
#pod |
31
|
|
|
|
|
|
|
#pod =head1 DESCRIPTION |
32
|
|
|
|
|
|
|
#pod |
33
|
|
|
|
|
|
|
#pod This is a backend for L implemented in pure perl, for those without a compiler or who would like to use this inline in scripts. |
34
|
|
|
|
|
|
|
#pod |
35
|
|
|
|
|
|
|
#pod =cut |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
sub new { |
38
|
62
|
|
|
62
|
0
|
36387
|
my $class = shift; |
39
|
62
|
|
|
|
|
158
|
my ($package) = @_; |
40
|
|
|
|
|
|
|
|
41
|
62
|
100
|
100
|
|
|
785
|
if (!defined($package) || (ref($package) && reftype($package) ne 'HASH')) { |
|
|
100
|
100
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
42
|
4
|
|
|
|
|
640
|
confess "Package::Stash->new must be passed the name of the " |
43
|
|
|
|
|
|
|
. "package to access"; |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
elsif (ref($package) && reftype($package) eq 'HASH') { |
46
|
1
|
|
|
|
|
1
|
confess "The PP implementation of Package::Stash does not support " |
47
|
|
|
|
|
|
|
. "anonymous stashes before perl 5.14" |
48
|
|
|
|
|
|
|
if BROKEN_GLOB_ASSIGNMENT; |
49
|
|
|
|
|
|
|
|
50
|
1
|
|
|
|
|
4
|
return bless { |
51
|
|
|
|
|
|
|
'namespace' => $package, |
52
|
|
|
|
|
|
|
}, $class; |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
elsif ($package =~ /\A[0-9A-Z_a-z]+(?:::[0-9A-Z_a-z]+)*\z/) { |
55
|
47
|
|
|
|
|
233
|
return bless { |
56
|
|
|
|
|
|
|
'package' => $package, |
57
|
|
|
|
|
|
|
}, $class; |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
else { |
60
|
10
|
|
|
|
|
1674
|
confess "$package is not a module name"; |
61
|
|
|
|
|
|
|
} |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
sub name { |
66
|
49
|
100
|
|
49
|
0
|
1819
|
confess "Can't call name as a class method" |
67
|
|
|
|
|
|
|
unless blessed($_[0]); |
68
|
|
|
|
|
|
|
confess "Can't get the name of an anonymous package" |
69
|
47
|
50
|
|
|
|
134
|
unless defined($_[0]->{package}); |
70
|
47
|
|
|
|
|
249
|
return $_[0]->{package}; |
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
sub namespace { |
74
|
372
|
50
|
|
372
|
0
|
1082
|
confess "Can't call namespace as a class method" |
75
|
|
|
|
|
|
|
unless blessed($_[0]); |
76
|
|
|
|
|
|
|
|
77
|
372
|
|
|
|
|
522
|
if (BROKEN_WEAK_STASH) { |
78
|
24
|
|
|
24
|
|
171
|
no strict 'refs'; |
|
24
|
|
|
|
|
46
|
|
|
24
|
|
|
|
|
1798
|
|
79
|
|
|
|
|
|
|
return \%{$_[0]->name . '::'}; |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
else { |
82
|
372
|
100
|
|
|
|
961
|
return $_[0]->{namespace} if defined $_[0]->{namespace}; |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
{ |
85
|
24
|
|
|
24
|
|
150
|
no strict 'refs'; |
|
24
|
|
|
|
|
38
|
|
|
24
|
|
|
|
|
13012
|
|
|
45
|
|
|
|
|
73
|
|
86
|
45
|
|
|
|
|
64
|
$_[0]->{namespace} = \%{$_[0]->name . '::'}; |
|
45
|
|
|
|
|
99
|
|
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
|
89
|
45
|
|
|
|
|
144
|
weaken($_[0]->{namespace}); |
90
|
|
|
|
|
|
|
|
91
|
45
|
|
|
|
|
87
|
return $_[0]->{namespace}; |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
{ |
96
|
|
|
|
|
|
|
my %SIGIL_MAP = ( |
97
|
|
|
|
|
|
|
'$' => 'SCALAR', |
98
|
|
|
|
|
|
|
'@' => 'ARRAY', |
99
|
|
|
|
|
|
|
'%' => 'HASH', |
100
|
|
|
|
|
|
|
'&' => 'CODE', |
101
|
|
|
|
|
|
|
'' => 'IO', |
102
|
|
|
|
|
|
|
); |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
sub _deconstruct_variable_name { |
105
|
359
|
|
|
359
|
|
578
|
my ($variable) = @_; |
106
|
|
|
|
|
|
|
|
107
|
359
|
|
|
|
|
429
|
my @ret; |
108
|
359
|
100
|
|
|
|
698
|
if (ref($variable) eq 'HASH') { |
109
|
88
|
|
|
|
|
112
|
@ret = @{$variable}{qw[name sigil type]}; |
|
88
|
|
|
|
|
187
|
|
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
else { |
112
|
271
|
50
|
33
|
|
|
1035
|
(defined $variable && length $variable) |
113
|
|
|
|
|
|
|
|| confess "You must pass a variable name"; |
114
|
|
|
|
|
|
|
|
115
|
271
|
|
|
|
|
630
|
my $sigil = substr($variable, 0, 1, ''); |
116
|
|
|
|
|
|
|
|
117
|
271
|
100
|
|
|
|
562
|
if (exists $SIGIL_MAP{$sigil}) { |
118
|
245
|
|
|
|
|
621
|
@ret = ($variable, $sigil, $SIGIL_MAP{$sigil}); |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
else { |
121
|
26
|
|
|
|
|
78
|
@ret = ("${sigil}${variable}", '', $SIGIL_MAP{''}); |
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
# XXX in pure perl, this will access things in inner packages, |
126
|
|
|
|
|
|
|
# in xs, this will segfault - probably look more into this at |
127
|
|
|
|
|
|
|
# some point |
128
|
359
|
100
|
|
|
|
1465
|
($ret[0] !~ /::/) |
129
|
|
|
|
|
|
|
|| confess "Variable names may not contain ::"; |
130
|
|
|
|
|
|
|
|
131
|
356
|
|
|
|
|
1014
|
return @ret; |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
sub _valid_for_type { |
136
|
68
|
|
|
68
|
|
137
|
my ($value, $type) = @_; |
137
|
68
|
100
|
100
|
|
|
382
|
if ($type eq 'HASH' || $type eq 'ARRAY' |
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
138
|
|
|
|
|
|
|
|| $type eq 'IO' || $type eq 'CODE') { |
139
|
43
|
|
|
|
|
916
|
return reftype($value) eq $type; |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
else { |
142
|
25
|
|
|
|
|
72
|
my $ref = reftype($value); |
143
|
25
|
|
100
|
|
|
1136
|
return !defined($ref) || $ref eq 'SCALAR' || $ref eq 'REF' || $ref eq 'LVALUE' || $ref eq 'REGEXP' || $ref eq 'VSTRING'; |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
sub add_symbol { |
148
|
78
|
|
|
78
|
0
|
28375
|
my ($self, $variable, $initial_value, %opts) = @_; |
149
|
|
|
|
|
|
|
|
150
|
78
|
|
|
|
|
201
|
my ($name, $sigil, $type) = _deconstruct_variable_name($variable); |
151
|
|
|
|
|
|
|
|
152
|
77
|
100
|
|
|
|
219
|
if (@_ > 2) { |
153
|
68
|
100
|
|
|
|
162
|
_valid_for_type($initial_value, $type) |
154
|
|
|
|
|
|
|
|| confess "$initial_value is not of type $type"; |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
# cheap fail-fast check for PERLDBf_SUBLINE and '&' |
157
|
59
|
100
|
66
|
|
|
357
|
if ($^P and $^P & 0x10 && $sigil eq '&') { |
|
|
|
66
|
|
|
|
|
158
|
2
|
|
|
|
|
5
|
my $filename = $opts{filename}; |
159
|
2
|
|
|
|
|
3
|
my $first_line_num = $opts{first_line_num}; |
160
|
|
|
|
|
|
|
|
161
|
2
|
100
|
|
|
|
7
|
(undef, $filename, $first_line_num) = caller |
162
|
|
|
|
|
|
|
if not defined $filename; |
163
|
|
|
|
|
|
|
|
164
|
2
|
|
66
|
|
|
10
|
my $last_line_num = $opts{last_line_num} || ($first_line_num ||= 0); |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
# http://perldoc.perl.org/perldebguts.html#Debugger-Internals |
167
|
2
|
|
|
|
|
12
|
$DB::sub{$self->name . '::' . $name} = "$filename:$first_line_num-$last_line_num"; |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
|
171
|
68
|
|
|
|
|
106
|
if (BROKEN_GLOB_ASSIGNMENT) { |
172
|
|
|
|
|
|
|
if (@_ > 2) { |
173
|
24
|
|
|
24
|
|
165
|
no strict 'refs'; |
|
24
|
|
|
|
|
41
|
|
|
24
|
|
|
|
|
836
|
|
174
|
24
|
|
|
24
|
|
131
|
no warnings 'redefine'; |
|
24
|
|
|
|
|
35
|
|
|
24
|
|
|
|
|
1530
|
|
175
|
|
|
|
|
|
|
*{ $self->name . '::' . $name } = ref $initial_value |
176
|
|
|
|
|
|
|
? $initial_value : \$initial_value; |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
else { |
179
|
24
|
|
|
24
|
|
153
|
no strict 'refs'; |
|
24
|
|
|
|
|
51
|
|
|
24
|
|
|
|
|
2205
|
|
180
|
|
|
|
|
|
|
if (BROKEN_ISA_ASSIGNMENT && $name eq 'ISA') { |
181
|
|
|
|
|
|
|
*{ $self->name . '::' . $name }; |
182
|
|
|
|
|
|
|
} |
183
|
|
|
|
|
|
|
else { |
184
|
|
|
|
|
|
|
my $undef = _undef_ref_for_type($type); |
185
|
|
|
|
|
|
|
*{ $self->name . '::' . $name } = $undef; |
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
else { |
190
|
68
|
|
|
|
|
164
|
my $namespace = $self->namespace; |
191
|
|
|
|
|
|
|
{ |
192
|
|
|
|
|
|
|
# using glob aliasing instead of Symbol::gensym, because otherwise, |
193
|
|
|
|
|
|
|
# magic doesn't get applied properly. |
194
|
|
|
|
|
|
|
# see <20120710063744.19360.qmail@lists-nntp.develooper.com> on p5p |
195
|
68
|
|
|
|
|
114
|
local *__ANON__:: = $namespace; |
|
68
|
|
|
|
|
251
|
|
196
|
24
|
|
|
24
|
|
134
|
no strict 'refs'; |
|
24
|
|
|
|
|
38
|
|
|
24
|
|
|
|
|
746
|
|
197
|
24
|
|
|
24
|
|
482
|
no warnings 'void'; |
|
24
|
|
|
|
|
75
|
|
|
24
|
|
|
|
|
935
|
|
198
|
24
|
|
|
24
|
|
161
|
no warnings 'once'; |
|
24
|
|
|
|
|
50
|
|
|
24
|
|
|
|
|
1919
|
|
199
|
68
|
|
|
|
|
131
|
*{"__ANON__::$name"}; |
|
68
|
|
|
|
|
315
|
|
200
|
|
|
|
|
|
|
} |
201
|
|
|
|
|
|
|
|
202
|
68
|
100
|
|
|
|
175
|
if (@_ > 2) { |
203
|
24
|
|
|
24
|
|
135
|
no warnings 'redefine'; |
|
24
|
|
|
|
|
39
|
|
|
24
|
|
|
|
|
12501
|
|
204
|
59
|
100
|
|
|
|
147
|
*{ $namespace->{$name} } = ref $initial_value |
|
59
|
|
|
|
|
1165
|
|
205
|
|
|
|
|
|
|
? $initial_value : \$initial_value; |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
else { |
208
|
9
|
|
|
|
|
13
|
return if BROKEN_ISA_ASSIGNMENT && $name eq 'ISA'; |
209
|
9
|
|
|
|
|
32
|
*{ $namespace->{$name} } = _undef_ref_for_type($type); |
|
9
|
|
|
|
|
69
|
|
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
sub _undef_ref_for_type { |
215
|
9
|
|
|
9
|
|
21
|
my ($type) = @_; |
216
|
|
|
|
|
|
|
|
217
|
9
|
100
|
|
|
|
48
|
if ($type eq 'ARRAY') { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
218
|
3
|
|
|
|
|
8
|
return []; |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
elsif ($type eq 'HASH') { |
221
|
2
|
|
|
|
|
6
|
return {}; |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
elsif ($type eq 'SCALAR') { |
224
|
3
|
|
|
|
|
6
|
return \undef; |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
elsif ($type eq 'IO') { |
227
|
1
|
|
|
|
|
5
|
return Symbol::geniosym; |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
elsif ($type eq 'CODE') { |
230
|
0
|
|
|
|
|
0
|
confess "Don't know how to vivify CODE variables"; |
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
else { |
233
|
0
|
|
|
|
|
0
|
confess "Unknown type $type in vivication"; |
234
|
|
|
|
|
|
|
} |
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
sub remove_glob { |
238
|
10
|
|
|
10
|
0
|
25
|
my ($self, $name) = @_; |
239
|
10
|
|
|
|
|
21
|
delete $self->namespace->{$name}; |
240
|
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
sub has_symbol { |
243
|
124
|
|
|
124
|
0
|
15971
|
my ($self, $variable) = @_; |
244
|
|
|
|
|
|
|
|
245
|
124
|
|
|
|
|
229
|
my ($name, $sigil, $type) = _deconstruct_variable_name($variable); |
246
|
|
|
|
|
|
|
|
247
|
124
|
|
|
|
|
254
|
my $namespace = $self->namespace; |
248
|
|
|
|
|
|
|
|
249
|
124
|
100
|
|
|
|
278
|
return unless exists $namespace->{$name}; |
250
|
|
|
|
|
|
|
|
251
|
120
|
|
|
|
|
186
|
my $entry_ref = \$namespace->{$name}; |
252
|
120
|
50
|
|
|
|
302
|
if (reftype($entry_ref) eq 'GLOB') { |
253
|
120
|
100
|
|
|
|
221
|
if ($type eq 'SCALAR') { |
254
|
31
|
|
|
|
|
56
|
if (BROKEN_SCALAR_INITIALIZATION) { |
255
|
|
|
|
|
|
|
return defined ${ *{$entry_ref}{$type} }; |
256
|
|
|
|
|
|
|
} |
257
|
|
|
|
|
|
|
else { |
258
|
31
|
|
|
|
|
313
|
my $sv = B::svref_2object($entry_ref)->SV; |
259
|
31
|
|
100
|
|
|
691
|
return $sv->isa('B::SV') |
260
|
|
|
|
|
|
|
|| ($sv->isa('B::SPECIAL') |
261
|
|
|
|
|
|
|
&& $B::specialsv_name[$$sv] ne 'Nullsv'); |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
else { |
265
|
89
|
|
|
|
|
120
|
return defined *{$entry_ref}{$type}; |
|
89
|
|
|
|
|
424
|
|
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
else { |
269
|
|
|
|
|
|
|
# a symbol table entry can be -1 (stub), string (stub with prototype), |
270
|
|
|
|
|
|
|
# or reference (constant) |
271
|
0
|
|
|
|
|
0
|
return $type eq 'CODE'; |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
sub get_symbol { |
276
|
147
|
|
|
147
|
0
|
26468
|
my ($self, $variable, %opts) = @_; |
277
|
|
|
|
|
|
|
|
278
|
147
|
|
|
|
|
282
|
my ($name, $sigil, $type) = _deconstruct_variable_name($variable); |
279
|
|
|
|
|
|
|
|
280
|
145
|
|
|
|
|
322
|
my $namespace = $self->namespace; |
281
|
|
|
|
|
|
|
|
282
|
145
|
100
|
|
|
|
336
|
if (!exists $namespace->{$name}) { |
283
|
13
|
100
|
|
|
|
41
|
if ($opts{vivify}) { |
284
|
7
|
|
|
|
|
25
|
$self->add_symbol($variable); |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
else { |
287
|
6
|
|
|
|
|
16
|
return undef; |
288
|
|
|
|
|
|
|
} |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
|
291
|
139
|
|
|
|
|
226
|
my $entry_ref = \$namespace->{$name}; |
292
|
|
|
|
|
|
|
|
293
|
139
|
100
|
|
|
|
286
|
if (ref($entry_ref) eq 'GLOB') { |
294
|
138
|
|
|
|
|
163
|
return *{$entry_ref}{$type}; |
|
138
|
|
|
|
|
3027
|
|
295
|
|
|
|
|
|
|
} |
296
|
|
|
|
|
|
|
else { |
297
|
1
|
50
|
|
|
|
10
|
if ($type eq 'CODE') { |
298
|
1
|
50
|
|
|
|
4
|
if (BROKEN_GLOB_ASSIGNMENT || defined($self->{package})) { |
299
|
24
|
|
|
24
|
|
173
|
no strict 'refs'; |
|
24
|
|
|
|
|
77
|
|
|
24
|
|
|
|
|
16285
|
|
300
|
0
|
|
|
|
|
0
|
return \&{ $self->name . '::' . $name }; |
|
0
|
|
|
|
|
0
|
|
301
|
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
# XXX we should really be able to support arbitrary anonymous |
304
|
|
|
|
|
|
|
# stashes here... (not just via Package::Anon) |
305
|
1
|
50
|
33
|
|
|
4
|
if (blessed($namespace) && $namespace->isa('Package::Anon')) { |
306
|
|
|
|
|
|
|
# ->can will call gv_init for us, which inflates the glob |
307
|
|
|
|
|
|
|
# don't know how to do this in general |
308
|
0
|
|
|
|
|
0
|
$namespace->bless(\(my $foo))->can($name); |
309
|
|
|
|
|
|
|
} |
310
|
|
|
|
|
|
|
else { |
311
|
1
|
|
|
|
|
227
|
confess "Don't know how to inflate a " . ref($entry_ref) |
312
|
|
|
|
|
|
|
. " into a full coderef (perhaps you could use" |
313
|
|
|
|
|
|
|
. " Package::Anon instead of a bare stash?)" |
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
|
316
|
0
|
|
|
|
|
0
|
return *{ $namespace->{$name} }{CODE}; |
|
0
|
|
|
|
|
0
|
|
317
|
|
|
|
|
|
|
} |
318
|
|
|
|
|
|
|
else { |
319
|
0
|
|
|
|
|
0
|
return undef; |
320
|
|
|
|
|
|
|
} |
321
|
|
|
|
|
|
|
} |
322
|
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
sub get_or_add_symbol { |
325
|
16
|
|
|
16
|
0
|
3361
|
my $self = shift; |
326
|
16
|
|
|
|
|
50
|
$self->get_symbol(@_, vivify => 1); |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
sub remove_symbol { |
330
|
10
|
|
|
10
|
1
|
3787
|
my ($self, $variable) = @_; |
331
|
|
|
|
|
|
|
|
332
|
10
|
|
|
|
|
29
|
my ($name, $sigil, $type) = _deconstruct_variable_name($variable); |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
# FIXME: |
335
|
|
|
|
|
|
|
# no doubt this is grossly inefficient and |
336
|
|
|
|
|
|
|
# could be done much easier and faster in XS |
337
|
|
|
|
|
|
|
|
338
|
10
|
|
|
|
|
145
|
my %desc = ( |
339
|
|
|
|
|
|
|
SCALAR => { sigil => '$', type => 'SCALAR', name => $name }, |
340
|
|
|
|
|
|
|
ARRAY => { sigil => '@', type => 'ARRAY', name => $name }, |
341
|
|
|
|
|
|
|
HASH => { sigil => '%', type => 'HASH', name => $name }, |
342
|
|
|
|
|
|
|
CODE => { sigil => '&', type => 'CODE', name => $name }, |
343
|
|
|
|
|
|
|
IO => { sigil => '', type => 'IO', name => $name }, |
344
|
|
|
|
|
|
|
); |
345
|
10
|
50
|
|
|
|
35
|
confess "This should never ever ever happen" if !$desc{$type}; |
346
|
|
|
|
|
|
|
|
347
|
10
|
100
|
|
|
|
36
|
my @types_to_store = grep { $type ne $_ && $self->has_symbol($desc{$_}) } |
|
50
|
|
|
|
|
191
|
|
348
|
|
|
|
|
|
|
keys %desc; |
349
|
10
|
|
|
|
|
35
|
my %values = map { $_, $self->get_symbol($desc{$_}) } @types_to_store; |
|
20
|
|
|
|
|
45
|
|
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
$values{SCALAR} = $self->get_symbol($desc{SCALAR}) |
352
|
|
|
|
|
|
|
if !defined $values{SCALAR} |
353
|
10
|
50
|
100
|
|
|
59
|
&& $type ne 'SCALAR' |
|
|
|
100
|
|
|
|
|
354
|
|
|
|
|
|
|
&& BROKEN_SCALAR_INITIALIZATION; |
355
|
|
|
|
|
|
|
|
356
|
10
|
|
|
|
|
43
|
$self->remove_glob($name); |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
$self->add_symbol($desc{$_} => $values{$_}) |
359
|
10
|
|
|
|
|
30
|
for grep { defined $values{$_} } keys %values; |
|
20
|
|
|
|
|
68
|
|
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
sub list_all_symbols { |
363
|
22
|
|
|
22
|
0
|
1104
|
my ($self, $type_filter) = @_; |
364
|
|
|
|
|
|
|
|
365
|
22
|
|
|
|
|
44
|
my $namespace = $self->namespace; |
366
|
22
|
|
|
|
|
44
|
if (HAS_ISA_CACHE) { |
367
|
|
|
|
|
|
|
return grep { $_ ne '::ISA::CACHE::' } keys %{$namespace} |
368
|
|
|
|
|
|
|
unless defined $type_filter; |
369
|
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
|
else { |
371
|
22
|
100
|
|
|
|
46
|
return keys %{$namespace} |
|
4
|
|
|
|
|
45
|
|
372
|
|
|
|
|
|
|
unless defined $type_filter; |
373
|
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
# NOTE: |
376
|
|
|
|
|
|
|
# or we can filter based on |
377
|
|
|
|
|
|
|
# type (SCALAR|ARRAY|HASH|CODE) |
378
|
18
|
100
|
|
|
|
69
|
if ($type_filter eq 'CODE') { |
|
|
100
|
|
|
|
|
|
379
|
|
|
|
|
|
|
return grep { |
380
|
|
|
|
|
|
|
# any non-typeglob in the symbol table is a constant or stub |
381
|
|
|
|
|
|
|
ref(\$namespace->{$_}) ne 'GLOB' |
382
|
|
|
|
|
|
|
# regular subs are stored in the CODE slot of the typeglob |
383
|
53
|
|
|
|
|
207
|
|| defined(*{$namespace->{$_}}{CODE}) |
384
|
7
|
50
|
|
|
|
11
|
} keys %{$namespace}; |
|
53
|
|
|
|
|
112
|
|
|
7
|
|
|
|
|
24
|
|
385
|
|
|
|
|
|
|
} |
386
|
|
|
|
|
|
|
elsif ($type_filter eq 'SCALAR') { |
387
|
|
|
|
|
|
|
return grep { |
388
|
|
|
|
|
|
|
!(HAS_ISA_CACHE && $_ eq '::ISA::CACHE::') && |
389
|
|
|
|
|
|
|
(BROKEN_SCALAR_INITIALIZATION |
390
|
|
|
|
|
|
|
? (ref(\$namespace->{$_}) eq 'GLOB' |
391
|
|
|
|
|
|
|
&& defined(${*{$namespace->{$_}}{'SCALAR'}})) |
392
|
17
|
|
|
|
|
21
|
: (do { |
393
|
17
|
|
|
|
|
24
|
my $entry = \$namespace->{$_}; |
394
|
17
|
50
|
|
|
|
187
|
ref($entry) eq 'GLOB' |
395
|
|
|
|
|
|
|
&& B::svref_2object($entry)->SV->isa('B::SV') |
396
|
|
|
|
|
|
|
})) |
397
|
3
|
|
|
|
|
8
|
} keys %{$namespace}; |
|
3
|
|
|
|
|
12
|
|
398
|
|
|
|
|
|
|
} |
399
|
|
|
|
|
|
|
else { |
400
|
|
|
|
|
|
|
return grep { |
401
|
|
|
|
|
|
|
ref(\$namespace->{$_}) eq 'GLOB' |
402
|
60
|
50
|
|
|
|
116
|
&& defined(*{$namespace->{$_}}{$type_filter}) |
|
60
|
|
|
|
|
234
|
|
403
|
8
|
|
|
|
|
14
|
} keys %{$namespace}; |
|
8
|
|
|
|
|
24
|
|
404
|
|
|
|
|
|
|
} |
405
|
|
|
|
|
|
|
} |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
sub get_all_symbols { |
408
|
6
|
|
|
6
|
0
|
1920
|
my ($self, $type_filter) = @_; |
409
|
|
|
|
|
|
|
|
410
|
6
|
|
|
|
|
18
|
my $namespace = $self->namespace; |
411
|
6
|
100
|
|
|
|
21
|
return { %{$namespace} } unless defined $type_filter; |
|
2
|
|
|
|
|
29
|
|
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
return { |
414
|
4
|
|
|
|
|
14
|
map { $_ => $self->get_symbol({name => $_, type => $type_filter}) } |
|
8
|
|
|
|
|
27
|
|
415
|
|
|
|
|
|
|
$self->list_all_symbols($type_filter) |
416
|
|
|
|
|
|
|
} |
417
|
|
|
|
|
|
|
} |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
__END__ |