line |
stmt |
bran |
cond |
sub |
time |
code |
1
|
|
|
|
|
|
/* gv.c |
2
|
|
|
|
|
|
* |
3
|
|
|
|
|
|
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, |
4
|
|
|
|
|
|
* 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others |
5
|
|
|
|
|
|
* |
6
|
|
|
|
|
|
* You may distribute under the terms of either the GNU General Public |
7
|
|
|
|
|
|
* License or the Artistic License, as specified in the README file. |
8
|
|
|
|
|
|
* |
9
|
|
|
|
|
|
*/ |
10
|
|
|
|
|
|
|
11
|
|
|
|
|
|
/* |
12
|
|
|
|
|
|
* 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure |
13
|
|
|
|
|
|
* of your inquisitiveness, I shall spend all the rest of my days in answering |
14
|
|
|
|
|
|
* you. What more do you want to know?' |
15
|
|
|
|
|
|
* 'The names of all the stars, and of all living things, and the whole |
16
|
|
|
|
|
|
* history of Middle-earth and Over-heaven and of the Sundering Seas,' |
17
|
|
|
|
|
|
* laughed Pippin. |
18
|
|
|
|
|
|
* |
19
|
|
|
|
|
|
* [p.599 of _The Lord of the Rings_, III/xi: "The PalantÃr"] |
20
|
|
|
|
|
|
*/ |
21
|
|
|
|
|
|
|
22
|
|
|
|
|
|
/* |
23
|
|
|
|
|
|
=head1 GV Functions |
24
|
|
|
|
|
|
|
25
|
|
|
|
|
|
A GV is a structure which corresponds to to a Perl typeglob, ie *foo. |
26
|
|
|
|
|
|
It is a structure that holds a pointer to a scalar, an array, a hash etc, |
27
|
|
|
|
|
|
corresponding to $foo, @foo, %foo. |
28
|
|
|
|
|
|
|
29
|
|
|
|
|
|
GVs are usually found as values in stashes (symbol table hashes) where |
30
|
|
|
|
|
|
Perl stores its global variables. |
31
|
|
|
|
|
|
|
32
|
|
|
|
|
|
=cut |
33
|
|
|
|
|
|
*/ |
34
|
|
|
|
|
|
|
35
|
|
|
|
|
|
#include "EXTERN.h" |
36
|
|
|
|
|
|
#define PERL_IN_GV_C |
37
|
|
|
|
|
|
#include "perl.h" |
38
|
|
|
|
|
|
#include "overload.c" |
39
|
|
|
|
|
|
#include "keywords.h" |
40
|
|
|
|
|
|
#include "feature.h" |
41
|
|
|
|
|
|
|
42
|
|
|
|
|
|
static const char S_autoload[] = "AUTOLOAD"; |
43
|
|
|
|
|
|
static const STRLEN S_autolen = sizeof(S_autoload)-1; |
44
|
|
|
|
|
|
|
45
|
|
|
|
|
|
GV * |
46
|
8978005
|
|
|
|
|
Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) |
47
|
|
|
|
|
|
{ |
48
|
|
|
|
|
|
SV **where; |
49
|
|
|
|
|
|
|
50
|
8978005
|
50
|
|
|
|
if ( |
51
|
|
|
|
|
|
!gv |
52
|
8978005
|
100
|
|
|
|
|| ( |
53
|
8978005
|
|
|
|
|
SvTYPE((const SV *)gv) != SVt_PVGV |
54
|
8978005
|
|
|
|
|
&& SvTYPE((const SV *)gv) != SVt_PVLV |
55
|
|
|
|
|
|
) |
56
|
|
|
|
|
|
) { |
57
|
|
|
|
|
|
const char *what; |
58
|
2
|
50
|
|
|
|
if (type == SVt_PVIO) { |
59
|
|
|
|
|
|
/* |
60
|
|
|
|
|
|
* if it walks like a dirhandle, then let's assume that |
61
|
|
|
|
|
|
* this is a dirhandle. |
62
|
|
|
|
|
|
*/ |
63
|
2
|
|
|
|
|
what = OP_IS_DIRHOP(PL_op->op_type) ? |
64
|
2
|
50
|
|
|
|
"dirhandle" : "filehandle"; |
65
|
0
|
0
|
|
|
|
} else if (type == SVt_PVHV) { |
66
|
|
|
|
|
|
what = "hash"; |
67
|
|
|
|
|
|
} else { |
68
|
0
|
0
|
|
|
|
what = type == SVt_PVAV ? "array" : "scalar"; |
69
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
/* diag_listed_as: Bad symbol for filehandle */ |
71
|
2
|
|
|
|
|
Perl_croak(aTHX_ "Bad symbol for %s", what); |
72
|
|
|
|
|
|
} |
73
|
|
|
|
|
|
|
74
|
8978003
|
100
|
|
|
|
if (type == SVt_PVHV) { |
75
|
510435
|
|
|
|
|
where = (SV **)&GvHV(gv); |
76
|
8467568
|
100
|
|
|
|
} else if (type == SVt_PVAV) { |
77
|
1292367
|
|
|
|
|
where = (SV **)&GvAV(gv); |
78
|
7175201
|
100
|
|
|
|
} else if (type == SVt_PVIO) { |
79
|
5044649
|
|
|
|
|
where = (SV **)&GvIOp(gv); |
80
|
|
|
|
|
|
} else { |
81
|
2130552
|
|
|
|
|
where = &GvSV(gv); |
82
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
84
|
8978003
|
100
|
|
|
|
if (!*where) |
85
|
8800493
|
|
|
|
|
*where = newSV_type(type); |
86
|
8978003
|
100
|
|
|
|
if (type == SVt_PVAV && GvNAMELEN(gv) == 3 |
|
|
100
|
|
|
|
|
87
|
514500
|
100
|
|
|
|
&& strnEQ(GvNAME(gv), "ISA", 3)) |
88
|
447148
|
|
|
|
|
sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0); |
89
|
8978003
|
|
|
|
|
return gv; |
90
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
92
|
|
|
|
|
|
GV * |
93
|
12864415
|
|
|
|
|
Perl_gv_fetchfile(pTHX_ const char *name) |
94
|
|
|
|
|
|
{ |
95
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_FETCHFILE; |
96
|
12864415
|
|
|
|
|
return gv_fetchfile_flags(name, strlen(name), 0); |
97
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
99
|
|
|
|
|
|
GV * |
100
|
13170899
|
|
|
|
|
Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, |
101
|
|
|
|
|
|
const U32 flags) |
102
|
|
|
|
|
|
{ |
103
|
|
|
|
|
|
dVAR; |
104
|
|
|
|
|
|
char smallbuf[128]; |
105
|
|
|
|
|
|
char *tmpbuf; |
106
|
13170899
|
|
|
|
|
const STRLEN tmplen = namelen + 2; |
107
|
|
|
|
|
|
GV *gv; |
108
|
|
|
|
|
|
|
109
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS; |
110
|
|
|
|
|
|
PERL_UNUSED_ARG(flags); |
111
|
|
|
|
|
|
|
112
|
13170899
|
50
|
|
|
|
if (!PL_defstash) |
113
|
|
|
|
|
|
return NULL; |
114
|
|
|
|
|
|
|
115
|
13170899
|
100
|
|
|
|
if (tmplen <= sizeof smallbuf) |
116
|
|
|
|
|
|
tmpbuf = smallbuf; |
117
|
|
|
|
|
|
else |
118
|
34
|
|
|
|
|
Newx(tmpbuf, tmplen, char); |
119
|
|
|
|
|
|
/* This is where the debugger's %{"::_<$filename"} hash is created */ |
120
|
13170899
|
|
|
|
|
tmpbuf[0] = '_'; |
121
|
13170899
|
|
|
|
|
tmpbuf[1] = '<'; |
122
|
13170899
|
|
|
|
|
memcpy(tmpbuf + 2, name, namelen); |
123
|
13170899
|
|
|
|
|
gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE); |
124
|
13170899
|
100
|
|
|
|
if (!isGV(gv)) { |
125
|
4626469
|
|
|
|
|
gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); |
126
|
|
|
|
|
|
#ifdef PERL_DONT_CREATE_GVSV |
127
|
4626469
|
|
|
|
|
GvSV(gv) = newSVpvn(name, namelen); |
128
|
|
|
|
|
|
#else |
129
|
|
|
|
|
|
sv_setpvn(GvSV(gv), name, namelen); |
130
|
|
|
|
|
|
#endif |
131
|
|
|
|
|
|
} |
132
|
13170899
|
100
|
|
|
|
if ((PERLDB_LINE || PERLDB_SAVESRC) && !GvAV(gv)) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
133
|
7340
|
50
|
|
|
|
hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile); |
134
|
13170899
|
100
|
|
|
|
if (tmpbuf != smallbuf) |
135
|
6714689
|
|
|
|
|
Safefree(tmpbuf); |
136
|
|
|
|
|
|
return gv; |
137
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
139
|
|
|
|
|
|
/* |
140
|
|
|
|
|
|
=for apidoc gv_const_sv |
141
|
|
|
|
|
|
|
142
|
|
|
|
|
|
If C is a typeglob whose subroutine entry is a constant sub eligible for |
143
|
|
|
|
|
|
inlining, or C is a placeholder reference that would be promoted to such |
144
|
|
|
|
|
|
a typeglob, then returns the value returned by the sub. Otherwise, returns |
145
|
|
|
|
|
|
NULL. |
146
|
|
|
|
|
|
|
147
|
|
|
|
|
|
=cut |
148
|
|
|
|
|
|
*/ |
149
|
|
|
|
|
|
|
150
|
|
|
|
|
|
SV * |
151
|
0
|
|
|
|
|
Perl_gv_const_sv(pTHX_ GV *gv) |
152
|
|
|
|
|
|
{ |
153
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_CONST_SV; |
154
|
|
|
|
|
|
|
155
|
0
|
0
|
|
|
|
if (SvTYPE(gv) == SVt_PVGV) |
156
|
0
|
0
|
|
|
|
return cv_const_sv(GvCVu(gv)); |
157
|
0
|
0
|
|
|
|
return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV ? SvRV(gv) : NULL; |
|
|
0
|
|
|
|
|
158
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
160
|
|
|
|
|
|
GP * |
161
|
38270290
|
|
|
|
|
Perl_newGP(pTHX_ GV *const gv) |
162
|
|
|
|
|
|
{ |
163
|
|
|
|
|
|
GP *gp; |
164
|
|
|
|
|
|
U32 hash; |
165
|
|
|
|
|
|
const char *file; |
166
|
|
|
|
|
|
STRLEN len; |
167
|
|
|
|
|
|
#ifndef USE_ITHREADS |
168
|
|
|
|
|
|
GV *filegv; |
169
|
|
|
|
|
|
#endif |
170
|
|
|
|
|
|
dVAR; |
171
|
|
|
|
|
|
|
172
|
|
|
|
|
|
PERL_ARGS_ASSERT_NEWGP; |
173
|
38270290
|
|
|
|
|
Newxz(gp, 1, GP); |
174
|
38270290
|
|
|
|
|
gp->gp_egv = gv; /* allow compiler to reuse gv after this */ |
175
|
|
|
|
|
|
#ifndef PERL_DONT_CREATE_GVSV |
176
|
|
|
|
|
|
gp->gp_sv = newSV(0); |
177
|
|
|
|
|
|
#endif |
178
|
|
|
|
|
|
|
179
|
|
|
|
|
|
/* PL_curcop should never be null here. */ |
180
|
|
|
|
|
|
assert(PL_curcop); |
181
|
|
|
|
|
|
/* But for non-debugging builds play it safe */ |
182
|
38270290
|
50
|
|
|
|
if (PL_curcop) { |
183
|
38270290
|
|
|
|
|
gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */ |
184
|
|
|
|
|
|
#ifdef USE_ITHREADS |
185
|
|
|
|
|
|
if (CopFILE(PL_curcop)) { |
186
|
|
|
|
|
|
file = CopFILE(PL_curcop); |
187
|
|
|
|
|
|
len = strlen(file); |
188
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
#else |
190
|
38270290
|
|
|
|
|
filegv = CopFILEGV(PL_curcop); |
191
|
38270290
|
100
|
|
|
|
if (filegv) { |
192
|
37976542
|
|
|
|
|
file = GvNAME(filegv)+2; |
193
|
37976542
|
|
|
|
|
len = GvNAMELEN(filegv)-2; |
194
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
#endif |
196
|
|
|
|
|
|
else goto no_file; |
197
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
else { |
199
|
|
|
|
|
|
no_file: |
200
|
|
|
|
|
|
file = ""; |
201
|
|
|
|
|
|
len = 0; |
202
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
204
|
38270290
|
|
|
|
|
PERL_HASH(hash, file, len); |
205
|
38270290
|
|
|
|
|
gp->gp_file_hek = share_hek(file, len, hash); |
206
|
38270290
|
|
|
|
|
gp->gp_refcnt = 1; |
207
|
|
|
|
|
|
|
208
|
38270290
|
|
|
|
|
return gp; |
209
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
211
|
|
|
|
|
|
/* Assign CvGV(cv) = gv, handling weak references. |
212
|
|
|
|
|
|
* See also S_anonymise_cv_maybe */ |
213
|
|
|
|
|
|
|
214
|
|
|
|
|
|
void |
215
|
34737669
|
|
|
|
|
Perl_cvgv_set(pTHX_ CV* cv, GV* gv) |
216
|
|
|
|
|
|
{ |
217
|
|
|
|
|
|
GV * const oldgv = CvGV(cv); |
218
|
|
|
|
|
|
HEK *hek; |
219
|
|
|
|
|
|
PERL_ARGS_ASSERT_CVGV_SET; |
220
|
|
|
|
|
|
|
221
|
34737669
|
100
|
|
|
|
if (oldgv == gv) |
222
|
|
|
|
|
|
return; |
223
|
|
|
|
|
|
|
224
|
31063026
|
100
|
|
|
|
if (oldgv) { |
225
|
5336596
|
100
|
|
|
|
if (CvCVGV_RC(cv)) { |
226
|
3049985
|
|
|
|
|
SvREFCNT_dec_NN(oldgv); |
227
|
3049985
|
|
|
|
|
CvCVGV_RC_off(cv); |
228
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
else { |
230
|
2286611
|
|
|
|
|
sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv)); |
231
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
} |
233
|
25726430
|
50
|
|
|
|
else if ((hek = CvNAME_HEK(cv))) unshare_hek(hek); |
234
|
|
|
|
|
|
|
235
|
31063024
|
|
|
|
|
SvANY(cv)->xcv_gv_u.xcv_gv = gv; |
236
|
|
|
|
|
|
assert(!CvCVGV_RC(cv)); |
237
|
|
|
|
|
|
|
238
|
31063024
|
100
|
|
|
|
if (!gv) |
239
|
|
|
|
|
|
return; |
240
|
|
|
|
|
|
|
241
|
25726432
|
50
|
|
|
|
if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
242
|
21932892
|
|
|
|
|
Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv)); |
243
|
|
|
|
|
|
else { |
244
|
3793540
|
|
|
|
|
CvCVGV_RC_on(cv); |
245
|
19659741
|
|
|
|
|
SvREFCNT_inc_simple_void_NN(gv); |
246
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
249
|
|
|
|
|
|
/* Assign CvSTASH(cv) = st, handling weak references. */ |
250
|
|
|
|
|
|
|
251
|
|
|
|
|
|
void |
252
|
22122421
|
|
|
|
|
Perl_cvstash_set(pTHX_ CV *cv, HV *st) |
253
|
|
|
|
|
|
{ |
254
|
22122421
|
|
|
|
|
HV *oldst = CvSTASH(cv); |
255
|
|
|
|
|
|
PERL_ARGS_ASSERT_CVSTASH_SET; |
256
|
22122421
|
100
|
|
|
|
if (oldst == st) |
257
|
22122421
|
|
|
|
|
return; |
258
|
22016853
|
100
|
|
|
|
if (oldst) |
259
|
2028
|
|
|
|
|
sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv)); |
260
|
22016853
|
|
|
|
|
SvANY(cv)->xcv_stash = st; |
261
|
22016853
|
50
|
|
|
|
if (st) |
262
|
22016853
|
|
|
|
|
Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv)); |
263
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
265
|
|
|
|
|
|
/* |
266
|
|
|
|
|
|
=for apidoc gv_init_pvn |
267
|
|
|
|
|
|
|
268
|
|
|
|
|
|
Converts a scalar into a typeglob. This is an incoercible typeglob; |
269
|
|
|
|
|
|
assigning a reference to it will assign to one of its slots, instead of |
270
|
|
|
|
|
|
overwriting it as happens with typeglobs created by SvSetSV. Converting |
271
|
|
|
|
|
|
any scalar that is SvOK() may produce unpredictable results and is reserved |
272
|
|
|
|
|
|
for perl's internal use. |
273
|
|
|
|
|
|
|
274
|
|
|
|
|
|
C is the scalar to be converted. |
275
|
|
|
|
|
|
|
276
|
|
|
|
|
|
C is the parent stash/package, if any. |
277
|
|
|
|
|
|
|
278
|
|
|
|
|
|
C and C give the name. The name must be unqualified; |
279
|
|
|
|
|
|
that is, it must not include the package name. If C is a |
280
|
|
|
|
|
|
stash element, it is the caller's responsibility to ensure that the name |
281
|
|
|
|
|
|
passed to this function matches the name of the element. If it does not |
282
|
|
|
|
|
|
match, perl's internal bookkeeping will get out of sync. |
283
|
|
|
|
|
|
|
284
|
|
|
|
|
|
C can be set to SVf_UTF8 if C is a UTF8 string, or |
285
|
|
|
|
|
|
the return value of SvUTF8(sv). It can also take the |
286
|
|
|
|
|
|
GV_ADDMULTI flag, which means to pretend that the GV has been |
287
|
|
|
|
|
|
seen before (i.e., suppress "Used once" warnings). |
288
|
|
|
|
|
|
|
289
|
|
|
|
|
|
=for apidoc gv_init |
290
|
|
|
|
|
|
|
291
|
|
|
|
|
|
The old form of gv_init_pvn(). It does not work with UTF8 strings, as it |
292
|
|
|
|
|
|
has no flags parameter. If the C parameter is set, the |
293
|
|
|
|
|
|
GV_ADDMULTI flag will be passed to gv_init_pvn(). |
294
|
|
|
|
|
|
|
295
|
|
|
|
|
|
=for apidoc gv_init_pv |
296
|
|
|
|
|
|
|
297
|
|
|
|
|
|
Same as gv_init_pvn(), but takes a nul-terminated string for the name |
298
|
|
|
|
|
|
instead of separate char * and length parameters. |
299
|
|
|
|
|
|
|
300
|
|
|
|
|
|
=for apidoc gv_init_sv |
301
|
|
|
|
|
|
|
302
|
|
|
|
|
|
Same as gv_init_pvn(), but takes an SV * for the name instead of separate |
303
|
|
|
|
|
|
char * and length parameters. C is currently unused. |
304
|
|
|
|
|
|
|
305
|
|
|
|
|
|
=cut |
306
|
|
|
|
|
|
*/ |
307
|
|
|
|
|
|
|
308
|
|
|
|
|
|
void |
309
|
2473042
|
|
|
|
|
Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags) |
310
|
|
|
|
|
|
{ |
311
|
|
|
|
|
|
char *namepv; |
312
|
|
|
|
|
|
STRLEN namelen; |
313
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_INIT_SV; |
314
|
2473042
|
50
|
|
|
|
namepv = SvPV(namesv, namelen); |
315
|
2473042
|
100
|
|
|
|
if (SvUTF8(namesv)) |
316
|
16
|
|
|
|
|
flags |= SVf_UTF8; |
317
|
2473042
|
|
|
|
|
gv_init_pvn(gv, stash, namepv, namelen, flags); |
318
|
2473042
|
|
|
|
|
} |
319
|
|
|
|
|
|
|
320
|
|
|
|
|
|
void |
321
|
2
|
|
|
|
|
Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags) |
322
|
|
|
|
|
|
{ |
323
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_INIT_PV; |
324
|
2
|
|
|
|
|
gv_init_pvn(gv, stash, name, strlen(name), flags); |
325
|
2
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
327
|
|
|
|
|
|
void |
328
|
35898302
|
|
|
|
|
Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags) |
329
|
|
|
|
|
|
{ |
330
|
|
|
|
|
|
dVAR; |
331
|
35898302
|
|
|
|
|
const U32 old_type = SvTYPE(gv); |
332
|
35898302
|
|
|
|
|
const bool doproto = old_type > SVt_NULL; |
333
|
5301788
|
100
|
|
|
|
char * const proto = (doproto && SvPOK(gv)) |
334
|
242441
|
|
|
|
|
? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv)) |
335
|
36363480
|
100
|
|
|
|
: NULL; |
|
|
100
|
|
|
|
|
336
|
35898302
|
100
|
|
|
|
const STRLEN protolen = proto ? SvCUR(gv) : 0; |
337
|
35898302
|
100
|
|
|
|
const U32 proto_utf8 = proto ? SvUTF8(gv) : 0; |
338
|
35898302
|
100
|
|
|
|
SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL; |
|
|
100
|
|
|
|
|
339
|
35898302
|
100
|
|
|
|
const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0; |
|
|
100
|
|
|
|
|
340
|
|
|
|
|
|
|
341
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_INIT_PVN; |
342
|
|
|
|
|
|
assert (!(proto && has_constant)); |
343
|
|
|
|
|
|
|
344
|
35898302
|
100
|
|
|
|
if (has_constant) { |
345
|
|
|
|
|
|
/* The constant has to be a simple scalar type. */ |
346
|
4785864
|
100
|
|
|
|
switch (SvTYPE(has_constant)) { |
347
|
|
|
|
|
|
case SVt_PVHV: |
348
|
|
|
|
|
|
case SVt_PVCV: |
349
|
|
|
|
|
|
case SVt_PVFM: |
350
|
|
|
|
|
|
case SVt_PVIO: |
351
|
20
|
|
|
|
|
Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob", |
352
|
|
|
|
|
|
sv_reftype(has_constant, 0)); |
353
|
|
|
|
|
|
default: NOOP; |
354
|
|
|
|
|
|
} |
355
|
4785844
|
|
|
|
|
SvRV_set(gv, NULL); |
356
|
4785844
|
|
|
|
|
SvROK_off(gv); |
357
|
|
|
|
|
|
} |
358
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
360
|
35898282
|
50
|
|
|
|
if (old_type < SVt_PVGV) { |
361
|
35898282
|
100
|
|
|
|
if (old_type >= SVt_PV) |
362
|
276032
|
|
|
|
|
SvCUR_set(gv, 0); |
363
|
35898282
|
|
|
|
|
sv_upgrade(MUTABLE_SV(gv), SVt_PVGV); |
364
|
|
|
|
|
|
} |
365
|
35898282
|
100
|
|
|
|
if (SvLEN(gv)) { |
366
|
276030
|
50
|
|
|
|
if (proto) { |
367
|
276030
|
|
|
|
|
SvPV_set(gv, NULL); |
368
|
276030
|
|
|
|
|
SvLEN_set(gv, 0); |
369
|
276030
|
|
|
|
|
SvPOK_off(gv); |
370
|
|
|
|
|
|
} else |
371
|
0
|
|
|
|
|
Safefree(SvPVX_mutable(gv)); |
372
|
|
|
|
|
|
} |
373
|
35898282
|
|
|
|
|
SvIOK_off(gv); |
374
|
35898282
|
|
|
|
|
isGV_with_GP_on(gv); |
375
|
|
|
|
|
|
|
376
|
35898282
|
|
|
|
|
GvGP_set(gv, Perl_newGP(aTHX_ gv)); |
377
|
35898282
|
|
|
|
|
GvSTASH(gv) = stash; |
378
|
35898282
|
100
|
|
|
|
if (stash) |
379
|
35690904
|
|
|
|
|
Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv)); |
380
|
35898282
|
|
|
|
|
gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 )); |
381
|
35898282
|
100
|
|
|
|
if (flags & GV_ADDMULTI || doproto) /* doproto means it */ |
|
|
100
|
|
|
|
|
382
|
24951871
|
|
|
|
|
GvMULTI_on(gv); /* _was_ mentioned */ |
383
|
35898282
|
100
|
|
|
|
if (doproto) { |
384
|
|
|
|
|
|
CV *cv; |
385
|
5301768
|
100
|
|
|
|
if (has_constant) { |
386
|
|
|
|
|
|
/* newCONSTSUB takes ownership of the reference from us. */ |
387
|
4785844
|
|
|
|
|
cv = newCONSTSUB_flags(stash, name, len, flags, has_constant); |
388
|
|
|
|
|
|
/* In case op.c:S_process_special_blocks stole it: */ |
389
|
4785844
|
100
|
|
|
|
if (!GvCV(gv)) |
390
|
4
|
|
|
|
|
GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv)); |
391
|
|
|
|
|
|
assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */ |
392
|
|
|
|
|
|
/* If this reference was a copy of another, then the subroutine |
393
|
|
|
|
|
|
must have been "imported", by a Perl space assignment to a GV |
394
|
|
|
|
|
|
from a reference to CV. */ |
395
|
4785844
|
100
|
|
|
|
if (exported_constant) |
396
|
1100232
|
|
|
|
|
GvIMPORTED_CV_on(gv); |
397
|
4785844
|
|
|
|
|
CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */ |
398
|
|
|
|
|
|
} else { |
399
|
515924
|
|
|
|
|
cv = newSTUB(gv,1); |
400
|
|
|
|
|
|
} |
401
|
5301768
|
100
|
|
|
|
if (proto) { |
402
|
276030
|
|
|
|
|
sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen, |
403
|
|
|
|
|
|
SV_HAS_TRAILING_NUL); |
404
|
276030
|
100
|
|
|
|
if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv)); |
405
|
|
|
|
|
|
} |
406
|
|
|
|
|
|
} |
407
|
35898282
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
409
|
|
|
|
|
|
STATIC void |
410
|
116782932
|
|
|
|
|
S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type) |
411
|
|
|
|
|
|
{ |
412
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_INIT_SVTYPE; |
413
|
|
|
|
|
|
|
414
|
116782932
|
|
|
|
|
switch (sv_type) { |
415
|
|
|
|
|
|
case SVt_PVIO: |
416
|
507167
|
50
|
|
|
|
(void)GvIOn(gv); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
417
|
|
|
|
|
|
break; |
418
|
|
|
|
|
|
case SVt_PVAV: |
419
|
11597269
|
100
|
|
|
|
(void)GvAVn(gv); |
420
|
|
|
|
|
|
break; |
421
|
|
|
|
|
|
case SVt_PVHV: |
422
|
3504716
|
100
|
|
|
|
(void)GvHVn(gv); |
423
|
|
|
|
|
|
break; |
424
|
|
|
|
|
|
#ifdef PERL_DONT_CREATE_GVSV |
425
|
|
|
|
|
|
case SVt_NULL: |
426
|
|
|
|
|
|
case SVt_PVCV: |
427
|
|
|
|
|
|
case SVt_PVFM: |
428
|
|
|
|
|
|
case SVt_PVGV: |
429
|
|
|
|
|
|
break; |
430
|
|
|
|
|
|
default: |
431
|
18854149
|
100
|
|
|
|
if(GvSVn(gv)) { |
432
|
|
|
|
|
|
/* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13 |
433
|
|
|
|
|
|
If we just cast GvSVn(gv) to void, it ignores evaluating it for |
434
|
|
|
|
|
|
its side effect */ |
435
|
|
|
|
|
|
} |
436
|
|
|
|
|
|
#endif |
437
|
|
|
|
|
|
} |
438
|
116782932
|
|
|
|
|
} |
439
|
|
|
|
|
|
|
440
|
|
|
|
|
|
static void core_xsub(pTHX_ CV* cv); |
441
|
|
|
|
|
|
|
442
|
|
|
|
|
|
static GV * |
443
|
13498
|
|
|
|
|
S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, |
444
|
|
|
|
|
|
const char * const name, const STRLEN len) |
445
|
|
|
|
|
|
{ |
446
|
13498
|
|
|
|
|
const int code = keyword(name, len, 1); |
447
|
|
|
|
|
|
static const char file[] = __FILE__; |
448
|
|
|
|
|
|
CV *cv, *oldcompcv = NULL; |
449
|
13498
|
|
|
|
|
int opnum = 0; |
450
|
|
|
|
|
|
bool ampable = TRUE; /* &{}-able */ |
451
|
|
|
|
|
|
COP *oldcurcop = NULL; |
452
|
|
|
|
|
|
yy_parser *oldparser = NULL; |
453
|
|
|
|
|
|
I32 oldsavestack_ix = 0; |
454
|
|
|
|
|
|
|
455
|
|
|
|
|
|
assert(gv || stash); |
456
|
|
|
|
|
|
assert(name); |
457
|
|
|
|
|
|
|
458
|
13498
|
100
|
|
|
|
if (!code) return NULL; /* Not a keyword */ |
459
|
12858
|
|
|
|
|
switch (code < 0 ? -code : code) { |
460
|
|
|
|
|
|
/* no support for \&CORE::infix; |
461
|
|
|
|
|
|
no support for funcs that do not parse like funcs */ |
462
|
|
|
|
|
|
case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD: |
463
|
|
|
|
|
|
case KEY_BEGIN : case KEY_CHECK : case KEY_cmp: case KEY_CORE : |
464
|
|
|
|
|
|
case KEY_default : case KEY_DESTROY: |
465
|
|
|
|
|
|
case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif : |
466
|
|
|
|
|
|
case KEY_END : case KEY_eq : case KEY_eval : |
467
|
|
|
|
|
|
case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge : |
468
|
|
|
|
|
|
case KEY_given : case KEY_goto : case KEY_grep : |
469
|
|
|
|
|
|
case KEY_gt : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le: |
470
|
|
|
|
|
|
case KEY_local: case KEY_lt: case KEY_m : case KEY_map : case KEY_my: |
471
|
|
|
|
|
|
case KEY_ne : case KEY_next : case KEY_no: case KEY_or: case KEY_our: |
472
|
|
|
|
|
|
case KEY_package: case KEY_print: case KEY_printf: |
473
|
|
|
|
|
|
case KEY_q : case KEY_qq : case KEY_qr : case KEY_qw : |
474
|
|
|
|
|
|
case KEY_qx : case KEY_redo : case KEY_require: case KEY_return: |
475
|
|
|
|
|
|
case KEY_s : case KEY_say : case KEY_sort : |
476
|
|
|
|
|
|
case KEY_state: case KEY_sub : |
477
|
|
|
|
|
|
case KEY_tr : case KEY_UNITCHECK: case KEY_unless: |
478
|
|
|
|
|
|
case KEY_until: case KEY_use : case KEY_when : case KEY_while : |
479
|
|
|
|
|
|
case KEY_x : case KEY_xor : case KEY_y : |
480
|
|
|
|
|
|
return NULL; |
481
|
|
|
|
|
|
case KEY_chdir: |
482
|
|
|
|
|
|
case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete: |
483
|
|
|
|
|
|
case KEY_each : case KEY_eof : case KEY_exec : case KEY_exists: |
484
|
|
|
|
|
|
case KEY_keys: |
485
|
|
|
|
|
|
case KEY_lstat: |
486
|
|
|
|
|
|
case KEY_pop: |
487
|
|
|
|
|
|
case KEY_push: |
488
|
|
|
|
|
|
case KEY_shift: |
489
|
|
|
|
|
|
case KEY_splice: case KEY_split: |
490
|
|
|
|
|
|
case KEY_stat: |
491
|
|
|
|
|
|
case KEY_system: |
492
|
|
|
|
|
|
case KEY_truncate: case KEY_unlink: |
493
|
|
|
|
|
|
case KEY_unshift: |
494
|
|
|
|
|
|
case KEY_values: |
495
|
|
|
|
|
|
ampable = FALSE; |
496
|
|
|
|
|
|
} |
497
|
816
|
100
|
|
|
|
if (!gv) { |
498
|
2
|
|
|
|
|
gv = (GV *)newSV(0); |
499
|
2
|
|
|
|
|
gv_init(gv, stash, name, len, TRUE); |
500
|
|
|
|
|
|
} |
501
|
816
|
|
|
|
|
GvMULTI_on(gv); |
502
|
816
|
100
|
|
|
|
if (ampable) { |
503
|
728
|
|
|
|
|
ENTER; |
504
|
728
|
|
|
|
|
oldcurcop = PL_curcop; |
505
|
728
|
|
|
|
|
oldparser = PL_parser; |
506
|
728
|
|
|
|
|
lex_start(NULL, NULL, 0); |
507
|
728
|
|
|
|
|
oldcompcv = PL_compcv; |
508
|
728
|
|
|
|
|
PL_compcv = NULL; /* Prevent start_subparse from setting |
509
|
|
|
|
|
|
CvOUTSIDE. */ |
510
|
728
|
|
|
|
|
oldsavestack_ix = start_subparse(FALSE,0); |
511
|
728
|
|
|
|
|
cv = PL_compcv; |
512
|
|
|
|
|
|
} |
513
|
|
|
|
|
|
else { |
514
|
|
|
|
|
|
/* Avoid calling newXS, as it calls us, and things start to |
515
|
|
|
|
|
|
get hairy. */ |
516
|
88
|
|
|
|
|
cv = MUTABLE_CV(newSV_type(SVt_PVCV)); |
517
|
88
|
|
|
|
|
GvCV_set(gv,cv); |
518
|
88
|
|
|
|
|
GvCVGEN(gv) = 0; |
519
|
88
|
|
|
|
|
mro_method_changed_in(GvSTASH(gv)); |
520
|
88
|
|
|
|
|
CvISXSUB_on(cv); |
521
|
88
|
|
|
|
|
CvXSUB(cv) = core_xsub; |
522
|
|
|
|
|
|
} |
523
|
816
|
|
|
|
|
CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE |
524
|
|
|
|
|
|
from PL_curcop. */ |
525
|
816
|
|
|
|
|
(void)gv_fetchfile(file); |
526
|
816
|
|
|
|
|
CvFILE(cv) = (char *)file; |
527
|
|
|
|
|
|
/* XXX This is inefficient, as doing things this order causes |
528
|
|
|
|
|
|
a prototype check in newATTRSUB. But we have to do |
529
|
|
|
|
|
|
it this order as we need an op number before calling |
530
|
|
|
|
|
|
new ATTRSUB. */ |
531
|
816
|
|
|
|
|
(void)core_prototype((SV *)cv, name, code, &opnum); |
532
|
816
|
100
|
|
|
|
if (stash) |
533
|
2
|
|
|
|
|
(void)hv_store(stash,name,len,(SV *)gv,0); |
534
|
816
|
100
|
|
|
|
if (ampable) { |
535
|
|
|
|
|
|
#ifdef DEBUGGING |
536
|
|
|
|
|
|
CV *orig_cv = cv; |
537
|
|
|
|
|
|
#endif |
538
|
728
|
|
|
|
|
CvLVALUE_on(cv); |
539
|
|
|
|
|
|
/* newATTRSUB will free the CV and return NULL if we're still |
540
|
|
|
|
|
|
compiling after a syntax error */ |
541
|
728
|
100
|
|
|
|
if ((cv = newATTRSUB_flags( |
|
|
100
|
|
|
|
|
542
|
|
|
|
|
|
oldsavestack_ix, (OP *)gv, |
543
|
|
|
|
|
|
NULL,NULL, |
544
|
|
|
|
|
|
coresub_op( |
545
|
|
|
|
|
|
opnum |
546
|
|
|
|
|
|
? newSVuv((UV)opnum) |
547
|
|
|
|
|
|
: newSVpvn(name,len), |
548
|
|
|
|
|
|
code, opnum |
549
|
|
|
|
|
|
), |
550
|
|
|
|
|
|
1 |
551
|
|
|
|
|
|
)) != NULL) { |
552
|
|
|
|
|
|
assert(GvCV(gv) == orig_cv); |
553
|
726
|
100
|
|
|
|
if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS |
554
|
714
|
100
|
|
|
|
&& opnum != OP_UNDEF) |
555
|
710
|
|
|
|
|
CvLVALUE_off(cv); /* Now *that* was a neat trick. */ |
556
|
|
|
|
|
|
} |
557
|
728
|
|
|
|
|
LEAVE; |
558
|
728
|
|
|
|
|
PL_parser = oldparser; |
559
|
728
|
|
|
|
|
PL_curcop = oldcurcop; |
560
|
728
|
|
|
|
|
PL_compcv = oldcompcv; |
561
|
|
|
|
|
|
} |
562
|
816
|
100
|
|
|
|
if (cv) { |
563
|
814
|
100
|
|
|
|
SV *opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL; |
564
|
814
|
100
|
|
|
|
cv_set_call_checker( |
565
|
|
|
|
|
|
cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv |
566
|
|
|
|
|
|
); |
567
|
7156
|
|
|
|
|
SvREFCNT_dec(opnumsv); |
568
|
|
|
|
|
|
} |
569
|
|
|
|
|
|
|
570
|
|
|
|
|
|
return gv; |
571
|
|
|
|
|
|
} |
572
|
|
|
|
|
|
|
573
|
|
|
|
|
|
/* |
574
|
|
|
|
|
|
=for apidoc gv_fetchmeth |
575
|
|
|
|
|
|
|
576
|
|
|
|
|
|
Like L, but lacks a flags parameter. |
577
|
|
|
|
|
|
|
578
|
|
|
|
|
|
=for apidoc gv_fetchmeth_sv |
579
|
|
|
|
|
|
|
580
|
|
|
|
|
|
Exactly like L, but takes the name string in the form |
581
|
|
|
|
|
|
of an SV instead of a string/length pair. |
582
|
|
|
|
|
|
|
583
|
|
|
|
|
|
=cut |
584
|
|
|
|
|
|
*/ |
585
|
|
|
|
|
|
|
586
|
|
|
|
|
|
GV * |
587
|
18
|
|
|
|
|
Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags) |
588
|
|
|
|
|
|
{ |
589
|
|
|
|
|
|
char *namepv; |
590
|
|
|
|
|
|
STRLEN namelen; |
591
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_FETCHMETH_SV; |
592
|
18
|
50
|
|
|
|
namepv = SvPV(namesv, namelen); |
593
|
18
|
100
|
|
|
|
if (SvUTF8(namesv)) |
594
|
4
|
|
|
|
|
flags |= SVf_UTF8; |
595
|
18
|
|
|
|
|
return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags); |
596
|
|
|
|
|
|
} |
597
|
|
|
|
|
|
|
598
|
|
|
|
|
|
/* |
599
|
|
|
|
|
|
=for apidoc gv_fetchmeth_pv |
600
|
|
|
|
|
|
|
601
|
|
|
|
|
|
Exactly like L, but takes a nul-terminated string |
602
|
|
|
|
|
|
instead of a string/length pair. |
603
|
|
|
|
|
|
|
604
|
|
|
|
|
|
=cut |
605
|
|
|
|
|
|
*/ |
606
|
|
|
|
|
|
|
607
|
|
|
|
|
|
GV * |
608
|
18
|
|
|
|
|
Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags) |
609
|
|
|
|
|
|
{ |
610
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_FETCHMETH_PV; |
611
|
18
|
|
|
|
|
return gv_fetchmeth_pvn(stash, name, strlen(name), level, flags); |
612
|
|
|
|
|
|
} |
613
|
|
|
|
|
|
|
614
|
|
|
|
|
|
/* |
615
|
|
|
|
|
|
=for apidoc gv_fetchmeth_pvn |
616
|
|
|
|
|
|
|
617
|
|
|
|
|
|
Returns the glob with the given C and a defined subroutine or |
618
|
|
|
|
|
|
C. The glob lives in the given C, or in the stashes |
619
|
|
|
|
|
|
accessible via @ISA and UNIVERSAL::. |
620
|
|
|
|
|
|
|
621
|
|
|
|
|
|
The argument C should be either 0 or -1. If C, as a |
622
|
|
|
|
|
|
side-effect creates a glob with the given C in the given C |
623
|
|
|
|
|
|
which in the case of success contains an alias for the subroutine, and sets |
624
|
|
|
|
|
|
up caching info for this glob. |
625
|
|
|
|
|
|
|
626
|
|
|
|
|
|
The only significant values for C are GV_SUPER and SVf_UTF8. |
627
|
|
|
|
|
|
|
628
|
|
|
|
|
|
GV_SUPER indicates that we want to look up the method in the superclasses |
629
|
|
|
|
|
|
of the C. |
630
|
|
|
|
|
|
|
631
|
|
|
|
|
|
The |
632
|
|
|
|
|
|
GV returned from C may be a method cache entry, which is not |
633
|
|
|
|
|
|
visible to Perl code. So when calling C, you should not use |
634
|
|
|
|
|
|
the GV directly; instead, you should use the method's CV, which can be |
635
|
|
|
|
|
|
obtained from the GV with the C macro. |
636
|
|
|
|
|
|
|
637
|
|
|
|
|
|
=cut |
638
|
|
|
|
|
|
*/ |
639
|
|
|
|
|
|
|
640
|
|
|
|
|
|
/* NOTE: No support for tied ISA */ |
641
|
|
|
|
|
|
|
642
|
|
|
|
|
|
GV * |
643
|
144632103
|
|
|
|
|
Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags) |
644
|
|
|
|
|
|
{ |
645
|
|
|
|
|
|
dVAR; |
646
|
|
|
|
|
|
GV** gvp; |
647
|
|
|
|
|
|
AV* linear_av; |
648
|
|
|
|
|
|
SV** linear_svp; |
649
|
|
|
|
|
|
SV* linear_sv; |
650
|
|
|
|
|
|
HV* cstash, *cachestash; |
651
|
|
|
|
|
|
GV* candidate = NULL; |
652
|
|
|
|
|
|
CV* cand_cv = NULL; |
653
|
|
|
|
|
|
GV* topgv = NULL; |
654
|
|
|
|
|
|
const char *hvname; |
655
|
144632103
|
|
|
|
|
I32 create = (level >= 0) ? 1 : 0; |
656
|
|
|
|
|
|
I32 items; |
657
|
|
|
|
|
|
U32 topgen_cmp; |
658
|
144632103
|
|
|
|
|
U32 is_utf8 = flags & SVf_UTF8; |
659
|
|
|
|
|
|
|
660
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_FETCHMETH_PVN; |
661
|
|
|
|
|
|
|
662
|
|
|
|
|
|
/* UNIVERSAL methods should be callable without a stash */ |
663
|
144632103
|
100
|
|
|
|
if (!stash) { |
664
|
|
|
|
|
|
create = 0; /* probably appropriate */ |
665
|
11608825
|
100
|
|
|
|
if(!(stash = gv_stashpvs("UNIVERSAL", 0))) |
666
|
|
|
|
|
|
return 0; |
667
|
|
|
|
|
|
} |
668
|
|
|
|
|
|
|
669
|
|
|
|
|
|
assert(stash); |
670
|
|
|
|
|
|
|
671
|
144632027
|
50
|
|
|
|
hvname = HvNAME_get(stash); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
672
|
144632027
|
100
|
|
|
|
if (!hvname) |
673
|
4
|
|
|
|
|
Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); |
674
|
|
|
|
|
|
|
675
|
|
|
|
|
|
assert(hvname); |
676
|
|
|
|
|
|
assert(name); |
677
|
|
|
|
|
|
|
678
|
|
|
|
|
|
DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n", |
679
|
|
|
|
|
|
flags & GV_SUPER ? "SUPER " : "",name,hvname) ); |
680
|
|
|
|
|
|
|
681
|
144632023
|
100
|
|
|
|
topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation; |
682
|
|
|
|
|
|
|
683
|
144632023
|
100
|
|
|
|
if (flags & GV_SUPER) { |
684
|
156508
|
100
|
|
|
|
if (!HvAUX(stash)->xhv_mro_meta->super) |
685
|
3824
|
|
|
|
|
HvAUX(stash)->xhv_mro_meta->super = newHV(); |
686
|
156508
|
|
|
|
|
cachestash = HvAUX(stash)->xhv_mro_meta->super; |
687
|
|
|
|
|
|
} |
688
|
|
|
|
|
|
else cachestash = stash; |
689
|
|
|
|
|
|
|
690
|
|
|
|
|
|
/* check locally for a real method or a cache entry */ |
691
|
144632023
|
100
|
|
|
|
gvp = (GV**)hv_fetch(cachestash, name, is_utf8 ? -(I32)len : (I32)len, |
|
|
100
|
|
|
|
|
692
|
|
|
|
|
|
create); |
693
|
144632023
|
100
|
|
|
|
if(gvp) { |
694
|
132992778
|
|
|
|
|
topgv = *gvp; |
695
|
|
|
|
|
|
have_gv: |
696
|
|
|
|
|
|
assert(topgv); |
697
|
132992782
|
100
|
|
|
|
if (SvTYPE(topgv) != SVt_PVGV) |
698
|
1422788
|
|
|
|
|
gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8); |
699
|
132992782
|
100
|
|
|
|
if ((cand_cv = GvCV(topgv))) { |
700
|
|
|
|
|
|
/* If genuine method or valid cache entry, use it */ |
701
|
110130686
|
100
|
|
|
|
if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) { |
|
|
100
|
|
|
|
|
702
|
|
|
|
|
|
return topgv; |
703
|
|
|
|
|
|
} |
704
|
|
|
|
|
|
else { |
705
|
|
|
|
|
|
/* stale cache entry, junk it and move on */ |
706
|
5141430
|
|
|
|
|
SvREFCNT_dec_NN(cand_cv); |
707
|
5141430
|
|
|
|
|
GvCV_set(topgv, NULL); |
708
|
|
|
|
|
|
cand_cv = NULL; |
709
|
5141430
|
|
|
|
|
GvCVGEN(topgv) = 0; |
710
|
|
|
|
|
|
} |
711
|
|
|
|
|
|
} |
712
|
22862096
|
100
|
|
|
|
else if (GvCVGEN(topgv) == topgen_cmp) { |
713
|
|
|
|
|
|
/* cache indicates no such method definitively */ |
714
|
|
|
|
|
|
return 0; |
715
|
|
|
|
|
|
} |
716
|
12583564
|
100
|
|
|
|
else if (stash == cachestash |
717
|
12578550
|
50
|
|
|
|
&& len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4 |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
718
|
17376
|
100
|
|
|
|
&& strnEQ(hvname, "CORE", 4) |
719
|
4
|
50
|
|
|
|
&& S_maybe_add_coresub(aTHX_ NULL,topgv,name,len)) |
720
|
|
|
|
|
|
goto have_gv; |
721
|
|
|
|
|
|
} |
722
|
|
|
|
|
|
|
723
|
25178308
|
|
|
|
|
linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */ |
724
|
25178308
|
|
|
|
|
linear_svp = AvARRAY(linear_av) + 1; /* skip over self */ |
725
|
25178308
|
|
|
|
|
items = AvFILLp(linear_av); /* no +1, to skip over self */ |
726
|
88596870
|
100
|
|
|
|
while (items--) { |
727
|
54895606
|
|
|
|
|
linear_sv = *linear_svp++; |
728
|
|
|
|
|
|
assert(linear_sv); |
729
|
54895606
|
|
|
|
|
cstash = gv_stashsv(linear_sv, 0); |
730
|
|
|
|
|
|
|
731
|
54895606
|
100
|
|
|
|
if (!cstash) { |
732
|
110
|
50
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), |
|
|
50
|
|
|
|
|
733
|
|
|
|
|
|
"Can't locate package %"SVf" for @%"HEKf"::ISA", |
734
|
|
|
|
|
|
SVfARG(linear_sv), |
735
|
88
|
50
|
|
|
|
HEKfARG(HvNAME_HEK(stash))); |
736
|
44
|
|
|
|
|
continue; |
737
|
|
|
|
|
|
} |
738
|
|
|
|
|
|
|
739
|
|
|
|
|
|
assert(cstash); |
740
|
|
|
|
|
|
|
741
|
54895562
|
100
|
|
|
|
gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0); |
742
|
54895562
|
100
|
|
|
|
if (!gvp) { |
743
|
28742114
|
100
|
|
|
|
if (len > 1 && HvNAMELEN_get(cstash) == 4) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
744
|
12644
|
50
|
|
|
|
const char *hvname = HvNAME(cstash); assert(hvname); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
745
|
12644
|
100
|
|
|
|
if (strnEQ(hvname, "CORE", 4) |
746
|
12568
|
100
|
|
|
|
&& (candidate = |
747
|
|
|
|
|
|
S_maybe_add_coresub(aTHX_ cstash,NULL,name,len) |
748
|
|
|
|
|
|
)) |
749
|
|
|
|
|
|
goto have_candidate; |
750
|
|
|
|
|
|
} |
751
|
28742112
|
|
|
|
|
continue; |
752
|
|
|
|
|
|
} |
753
|
26153448
|
|
|
|
|
else candidate = *gvp; |
754
|
|
|
|
|
|
have_candidate: |
755
|
|
|
|
|
|
assert(candidate); |
756
|
26153450
|
50
|
|
|
|
if (SvTYPE(candidate) != SVt_PVGV) |
757
|
0
|
|
|
|
|
gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8); |
758
|
26153450
|
50
|
|
|
|
if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
759
|
|
|
|
|
|
/* |
760
|
|
|
|
|
|
* Found real method, cache method in topgv if: |
761
|
|
|
|
|
|
* 1. topgv has no synonyms (else inheritance crosses wires) |
762
|
|
|
|
|
|
* 2. method isn't a stub (else AUTOLOAD fails spectacularly) |
763
|
|
|
|
|
|
*/ |
764
|
4024336
|
100
|
|
|
|
if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
765
|
4005608
|
|
|
|
|
CV *old_cv = GvCV(topgv); |
766
|
4005608
|
|
|
|
|
SvREFCNT_dec(old_cv); |
767
|
4005608
|
|
|
|
|
SvREFCNT_inc_simple_void_NN(cand_cv); |
768
|
4005608
|
|
|
|
|
GvCV_set(topgv, cand_cv); |
769
|
29447183
|
|
|
|
|
GvCVGEN(topgv) = topgen_cmp; |
770
|
|
|
|
|
|
} |
771
|
|
|
|
|
|
return candidate; |
772
|
|
|
|
|
|
} |
773
|
|
|
|
|
|
} |
774
|
|
|
|
|
|
|
775
|
|
|
|
|
|
/* Check UNIVERSAL without caching */ |
776
|
21153972
|
100
|
|
|
|
if(level == 0 || level == -1) { |
777
|
11607979
|
|
|
|
|
candidate = gv_fetchmeth_pvn(NULL, name, len, 1, flags &~GV_SUPER); |
778
|
11607979
|
100
|
|
|
|
if(candidate) { |
779
|
2039988
|
|
|
|
|
cand_cv = GvCV(candidate); |
780
|
2039988
|
50
|
|
|
|
if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
781
|
2039986
|
|
|
|
|
CV *old_cv = GvCV(topgv); |
782
|
2039986
|
|
|
|
|
SvREFCNT_dec(old_cv); |
783
|
2039986
|
|
|
|
|
SvREFCNT_inc_simple_void_NN(cand_cv); |
784
|
2039986
|
|
|
|
|
GvCV_set(topgv, cand_cv); |
785
|
2039986
|
|
|
|
|
GvCVGEN(topgv) = topgen_cmp; |
786
|
|
|
|
|
|
} |
787
|
|
|
|
|
|
return candidate; |
788
|
|
|
|
|
|
} |
789
|
|
|
|
|
|
} |
790
|
|
|
|
|
|
|
791
|
19113984
|
100
|
|
|
|
if (topgv && GvREFCNT(topgv) == 1) { |
|
|
100
|
|
|
|
|
792
|
|
|
|
|
|
/* cache the fact that the method is not defined */ |
793
|
76102503
|
|
|
|
|
GvCVGEN(topgv) = topgen_cmp; |
794
|
|
|
|
|
|
} |
795
|
|
|
|
|
|
|
796
|
|
|
|
|
|
return 0; |
797
|
|
|
|
|
|
} |
798
|
|
|
|
|
|
|
799
|
|
|
|
|
|
/* |
800
|
|
|
|
|
|
=for apidoc gv_fetchmeth_autoload |
801
|
|
|
|
|
|
|
802
|
|
|
|
|
|
This is the old form of L, which has no flags |
803
|
|
|
|
|
|
parameter. |
804
|
|
|
|
|
|
|
805
|
|
|
|
|
|
=for apidoc gv_fetchmeth_sv_autoload |
806
|
|
|
|
|
|
|
807
|
|
|
|
|
|
Exactly like L, but takes the name string in the form |
808
|
|
|
|
|
|
of an SV instead of a string/length pair. |
809
|
|
|
|
|
|
|
810
|
|
|
|
|
|
=cut |
811
|
|
|
|
|
|
*/ |
812
|
|
|
|
|
|
|
813
|
|
|
|
|
|
GV * |
814
|
28
|
|
|
|
|
Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags) |
815
|
|
|
|
|
|
{ |
816
|
|
|
|
|
|
char *namepv; |
817
|
|
|
|
|
|
STRLEN namelen; |
818
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD; |
819
|
28
|
50
|
|
|
|
namepv = SvPV(namesv, namelen); |
820
|
28
|
100
|
|
|
|
if (SvUTF8(namesv)) |
821
|
6
|
|
|
|
|
flags |= SVf_UTF8; |
822
|
28
|
|
|
|
|
return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags); |
823
|
|
|
|
|
|
} |
824
|
|
|
|
|
|
|
825
|
|
|
|
|
|
/* |
826
|
|
|
|
|
|
=for apidoc gv_fetchmeth_pv_autoload |
827
|
|
|
|
|
|
|
828
|
|
|
|
|
|
Exactly like L, but takes a nul-terminated string |
829
|
|
|
|
|
|
instead of a string/length pair. |
830
|
|
|
|
|
|
|
831
|
|
|
|
|
|
=cut |
832
|
|
|
|
|
|
*/ |
833
|
|
|
|
|
|
|
834
|
|
|
|
|
|
GV * |
835
|
24
|
|
|
|
|
Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags) |
836
|
|
|
|
|
|
{ |
837
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD; |
838
|
24
|
|
|
|
|
return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags); |
839
|
|
|
|
|
|
} |
840
|
|
|
|
|
|
|
841
|
|
|
|
|
|
/* |
842
|
|
|
|
|
|
=for apidoc gv_fetchmeth_pvn_autoload |
843
|
|
|
|
|
|
|
844
|
|
|
|
|
|
Same as gv_fetchmeth_pvn(), but looks for autoloaded subroutines too. |
845
|
|
|
|
|
|
Returns a glob for the subroutine. |
846
|
|
|
|
|
|
|
847
|
|
|
|
|
|
For an autoloaded subroutine without a GV, will create a GV even |
848
|
|
|
|
|
|
if C. For an autoloaded subroutine without a stub, GvCV() |
849
|
|
|
|
|
|
of the result may be zero. |
850
|
|
|
|
|
|
|
851
|
|
|
|
|
|
Currently, the only significant value for C is SVf_UTF8. |
852
|
|
|
|
|
|
|
853
|
|
|
|
|
|
=cut |
854
|
|
|
|
|
|
*/ |
855
|
|
|
|
|
|
|
856
|
|
|
|
|
|
GV * |
857
|
4176327
|
|
|
|
|
Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags) |
858
|
|
|
|
|
|
{ |
859
|
4176327
|
|
|
|
|
GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags); |
860
|
|
|
|
|
|
|
861
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD; |
862
|
|
|
|
|
|
|
863
|
4176327
|
100
|
|
|
|
if (!gv) { |
864
|
|
|
|
|
|
CV *cv; |
865
|
|
|
|
|
|
GV **gvp; |
866
|
|
|
|
|
|
|
867
|
3974422
|
50
|
|
|
|
if (!stash) |
868
|
|
|
|
|
|
return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */ |
869
|
3974422
|
50
|
|
|
|
if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) |
|
|
0
|
|
|
|
|
870
|
|
|
|
|
|
return NULL; |
871
|
3974422
|
100
|
|
|
|
if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags))) |
872
|
|
|
|
|
|
return NULL; |
873
|
332
|
|
|
|
|
cv = GvCV(gv); |
874
|
332
|
100
|
|
|
|
if (!(CvROOT(cv) || CvXSUB(cv))) |
|
|
50
|
|
|
|
|
875
|
|
|
|
|
|
return NULL; |
876
|
|
|
|
|
|
/* Have an autoload */ |
877
|
330
|
100
|
|
|
|
if (level < 0) /* Cannot do without a stub */ |
878
|
16
|
|
|
|
|
gv_fetchmeth_pvn(stash, name, len, 0, flags); |
879
|
330
|
100
|
|
|
|
gvp = (GV**)hv_fetch(stash, name, |
|
|
100
|
|
|
|
|
880
|
|
|
|
|
|
(flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0)); |
881
|
330
|
50
|
|
|
|
if (!gvp) |
882
|
|
|
|
|
|
return NULL; |
883
|
2090487
|
|
|
|
|
return *gvp; |
884
|
|
|
|
|
|
} |
885
|
|
|
|
|
|
return gv; |
886
|
|
|
|
|
|
} |
887
|
|
|
|
|
|
|
888
|
|
|
|
|
|
/* |
889
|
|
|
|
|
|
=for apidoc gv_fetchmethod_autoload |
890
|
|
|
|
|
|
|
891
|
|
|
|
|
|
Returns the glob which contains the subroutine to call to invoke the method |
892
|
|
|
|
|
|
on the C. In fact in the presence of autoloading this may be the |
893
|
|
|
|
|
|
glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is |
894
|
|
|
|
|
|
already setup. |
895
|
|
|
|
|
|
|
896
|
|
|
|
|
|
The third parameter of C determines whether |
897
|
|
|
|
|
|
AUTOLOAD lookup is performed if the given method is not present: non-zero |
898
|
|
|
|
|
|
means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD. |
899
|
|
|
|
|
|
Calling C is equivalent to calling C |
900
|
|
|
|
|
|
with a non-zero C parameter. |
901
|
|
|
|
|
|
|
902
|
|
|
|
|
|
These functions grant C<"SUPER"> token as a prefix of the method name. Note |
903
|
|
|
|
|
|
that if you want to keep the returned glob for a long time, you need to |
904
|
|
|
|
|
|
check for it being "AUTOLOAD", since at the later time the call may load a |
905
|
|
|
|
|
|
different subroutine due to $AUTOLOAD changing its value. Use the glob |
906
|
|
|
|
|
|
created via a side effect to do this. |
907
|
|
|
|
|
|
|
908
|
|
|
|
|
|
These functions have the same side-effects and as C with |
909
|
|
|
|
|
|
C. C should be writable if contains C<':'> or C<' |
910
|
|
|
|
|
|
''>. The warning against passing the GV returned by C to |
911
|
|
|
|
|
|
C apply equally to these functions. |
912
|
|
|
|
|
|
|
913
|
|
|
|
|
|
=cut |
914
|
|
|
|
|
|
*/ |
915
|
|
|
|
|
|
|
916
|
|
|
|
|
|
GV * |
917
|
87680
|
|
|
|
|
Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) |
918
|
|
|
|
|
|
{ |
919
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD; |
920
|
|
|
|
|
|
|
921
|
87680
|
100
|
|
|
|
return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0); |
922
|
|
|
|
|
|
} |
923
|
|
|
|
|
|
|
924
|
|
|
|
|
|
GV * |
925
|
122100687
|
|
|
|
|
Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags) |
926
|
|
|
|
|
|
{ |
927
|
|
|
|
|
|
char *namepv; |
928
|
|
|
|
|
|
STRLEN namelen; |
929
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS; |
930
|
122100687
|
100
|
|
|
|
namepv = SvPV(namesv, namelen); |
931
|
122100687
|
100
|
|
|
|
if (SvUTF8(namesv)) |
932
|
762
|
|
|
|
|
flags |= SVf_UTF8; |
933
|
122100687
|
|
|
|
|
return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags); |
934
|
|
|
|
|
|
} |
935
|
|
|
|
|
|
|
936
|
|
|
|
|
|
GV * |
937
|
87696
|
|
|
|
|
Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags) |
938
|
|
|
|
|
|
{ |
939
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS; |
940
|
87696
|
|
|
|
|
return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags); |
941
|
|
|
|
|
|
} |
942
|
|
|
|
|
|
|
943
|
|
|
|
|
|
/* Don't merge this yet, as it's likely to get a len parameter, and possibly |
944
|
|
|
|
|
|
even a U32 hash */ |
945
|
|
|
|
|
|
GV * |
946
|
122188397
|
|
|
|
|
Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags) |
947
|
|
|
|
|
|
{ |
948
|
|
|
|
|
|
dVAR; |
949
|
|
|
|
|
|
const char *nend; |
950
|
|
|
|
|
|
const char *nsplit = NULL; |
951
|
|
|
|
|
|
GV* gv; |
952
|
|
|
|
|
|
HV* ostash = stash; |
953
|
|
|
|
|
|
const char * const origname = name; |
954
|
|
|
|
|
|
SV *const error_report = MUTABLE_SV(stash); |
955
|
122188397
|
|
|
|
|
const U32 autoload = flags & GV_AUTOLOAD; |
956
|
122188397
|
|
|
|
|
const U32 do_croak = flags & GV_CROAK; |
957
|
122188397
|
|
|
|
|
const U32 is_utf8 = flags & SVf_UTF8; |
958
|
|
|
|
|
|
|
959
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS; |
960
|
|
|
|
|
|
|
961
|
122188397
|
100
|
|
|
|
if (SvTYPE(stash) < SVt_PVHV) |
962
|
|
|
|
|
|
stash = NULL; |
963
|
|
|
|
|
|
else { |
964
|
|
|
|
|
|
/* The only way stash can become NULL later on is if nsplit is set, |
965
|
|
|
|
|
|
which in turn means that there is no need for a SVt_PVHV case |
966
|
|
|
|
|
|
the error reporting code. */ |
967
|
|
|
|
|
|
} |
968
|
|
|
|
|
|
|
969
|
874589114
|
100
|
|
|
|
for (nend = name; *nend || nend != (origname + len); nend++) { |
|
|
100
|
|
|
|
|
970
|
752400717
|
50
|
|
|
|
if (*nend == '\'') { |
971
|
|
|
|
|
|
nsplit = nend; |
972
|
0
|
|
|
|
|
name = nend + 1; |
973
|
|
|
|
|
|
} |
974
|
752400717
|
100
|
|
|
|
else if (*nend == ':' && *(nend + 1) == ':') { |
|
|
50
|
|
|
|
|
975
|
167128
|
|
|
|
|
nsplit = nend++; |
976
|
167128
|
|
|
|
|
name = nend + 1; |
977
|
|
|
|
|
|
} |
978
|
|
|
|
|
|
} |
979
|
122188397
|
100
|
|
|
|
if (nsplit) { |
980
|
166786
|
100
|
|
|
|
if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) { |
|
|
100
|
|
|
|
|
981
|
|
|
|
|
|
/* ->SUPER::method should really be looked up in original stash */ |
982
|
156504
|
|
|
|
|
stash = CopSTASH(PL_curcop); |
983
|
156504
|
|
|
|
|
flags |= GV_SUPER; |
984
|
|
|
|
|
|
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", |
985
|
|
|
|
|
|
origname, HvENAME_get(stash), name) ); |
986
|
|
|
|
|
|
} |
987
|
14724
|
100
|
|
|
|
else if ((nsplit - origname) >= 7 && |
|
|
100
|
|
|
|
|
988
|
9964
|
|
|
|
|
strnEQ(nsplit - 7, "::SUPER", 7)) { |
989
|
|
|
|
|
|
/* don't autovifify if ->NoSuchStash::SUPER::method */ |
990
|
4
|
|
|
|
|
stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8); |
991
|
4
|
50
|
|
|
|
if (stash) flags |= GV_SUPER; |
992
|
|
|
|
|
|
} |
993
|
|
|
|
|
|
else { |
994
|
|
|
|
|
|
/* don't autovifify if ->NoSuchStash::method */ |
995
|
88712
|
|
|
|
|
stash = gv_stashpvn(origname, nsplit - origname, is_utf8); |
996
|
|
|
|
|
|
} |
997
|
|
|
|
|
|
ostash = stash; |
998
|
|
|
|
|
|
} |
999
|
|
|
|
|
|
|
1000
|
122188397
|
|
|
|
|
gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags); |
1001
|
122188393
|
100
|
|
|
|
if (!gv) { |
1002
|
13983500
|
100
|
|
|
|
if (strEQ(name,"import") || strEQ(name,"unimport")) |
|
|
50
|
|
|
|
|
1003
|
|
|
|
|
|
gv = MUTABLE_GV(&PL_sv_yes); |
1004
|
11483578
|
100
|
|
|
|
else if (autoload) |
1005
|
28118
|
|
|
|
|
gv = gv_autoload_pvn( |
1006
|
|
|
|
|
|
ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags |
1007
|
|
|
|
|
|
); |
1008
|
13983500
|
100
|
|
|
|
if (!gv && do_croak) { |
1009
|
|
|
|
|
|
/* Right now this is exclusively for the benefit of S_method_common |
1010
|
|
|
|
|
|
in pp_hot.c */ |
1011
|
358
|
100
|
|
|
|
if (stash) { |
1012
|
|
|
|
|
|
/* If we can't find an IO::File method, it might be a call on |
1013
|
|
|
|
|
|
* a filehandle. If IO:File has not been loaded, try to |
1014
|
|
|
|
|
|
* require it first instead of croaking */ |
1015
|
332
|
50
|
|
|
|
const char *stash_name = HvNAME_get(stash); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1016
|
332
|
50
|
|
|
|
if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File") |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1017
|
12
|
50
|
|
|
|
&& !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL, |
|
|
50
|
|
|
|
|
1018
|
|
|
|
|
|
STR_WITH_LEN("IO/File.pm"), 0, |
1019
|
|
|
|
|
|
HV_FETCH_ISEXISTS, NULL, 0) |
1020
|
|
|
|
|
|
) { |
1021
|
12
|
|
|
|
|
require_pv("IO/File.pm"); |
1022
|
12
|
|
|
|
|
gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags); |
1023
|
12
|
50
|
|
|
|
if (gv) |
1024
|
|
|
|
|
|
return gv; |
1025
|
|
|
|
|
|
} |
1026
|
960
|
50
|
|
|
|
Perl_croak(aTHX_ |
|
|
50
|
|
|
|
|
1027
|
|
|
|
|
|
"Can't locate object method \"%"UTF8f |
1028
|
|
|
|
|
|
"\" via package \"%"HEKf"\"", |
1029
|
320
|
|
|
|
|
UTF8fARG(is_utf8, nend - name, name), |
1030
|
640
|
50
|
|
|
|
HEKfARG(HvNAME_HEK(stash))); |
1031
|
|
|
|
|
|
} |
1032
|
|
|
|
|
|
else { |
1033
|
|
|
|
|
|
SV* packnamesv; |
1034
|
|
|
|
|
|
|
1035
|
26
|
100
|
|
|
|
if (nsplit) { |
1036
|
8
|
|
|
|
|
packnamesv = newSVpvn_flags(origname, nsplit - origname, |
1037
|
|
|
|
|
|
SVs_TEMP | is_utf8); |
1038
|
|
|
|
|
|
} else { |
1039
|
|
|
|
|
|
packnamesv = error_report; |
1040
|
|
|
|
|
|
} |
1041
|
|
|
|
|
|
|
1042
|
26
|
|
|
|
|
Perl_croak(aTHX_ |
1043
|
|
|
|
|
|
"Can't locate object method \"%"UTF8f |
1044
|
|
|
|
|
|
"\" via package \"%"SVf"\"" |
1045
|
|
|
|
|
|
" (perhaps you forgot to load \"%"SVf"\"?)", |
1046
|
26
|
|
|
|
|
UTF8fARG(is_utf8, nend - name, name), |
1047
|
|
|
|
|
|
SVfARG(packnamesv), SVfARG(packnamesv)); |
1048
|
|
|
|
|
|
} |
1049
|
|
|
|
|
|
} |
1050
|
|
|
|
|
|
} |
1051
|
108204893
|
100
|
|
|
|
else if (autoload) { |
1052
|
44110101
|
|
|
|
|
CV* const cv = GvCV(gv); |
1053
|
44110101
|
100
|
|
|
|
if (!CvROOT(cv) && !CvXSUB(cv)) { |
|
|
50
|
|
|
|
|
1054
|
|
|
|
|
|
GV* stubgv; |
1055
|
|
|
|
|
|
GV* autogv; |
1056
|
|
|
|
|
|
|
1057
|
674
|
50
|
|
|
|
if (CvANON(cv)) |
1058
|
|
|
|
|
|
stubgv = gv; |
1059
|
|
|
|
|
|
else { |
1060
|
|
|
|
|
|
stubgv = CvGV(cv); |
1061
|
674
|
50
|
|
|
|
if (GvCV(stubgv) != cv) /* orphaned import */ |
1062
|
|
|
|
|
|
stubgv = gv; |
1063
|
|
|
|
|
|
} |
1064
|
674
|
50
|
|
|
|
autogv = gv_autoload_pvn(GvSTASH(stubgv), |
1065
|
|
|
|
|
|
GvNAME(stubgv), GvNAMELEN(stubgv), |
1066
|
|
|
|
|
|
GV_AUTOLOAD_ISMETHOD |
1067
|
|
|
|
|
|
| (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0)); |
1068
|
674
|
100
|
|
|
|
if (autogv) |
1069
|
|
|
|
|
|
gv = autogv; |
1070
|
|
|
|
|
|
} |
1071
|
|
|
|
|
|
} |
1072
|
|
|
|
|
|
|
1073
|
122188041
|
|
|
|
|
return gv; |
1074
|
|
|
|
|
|
} |
1075
|
|
|
|
|
|
|
1076
|
|
|
|
|
|
GV* |
1077
|
10
|
|
|
|
|
Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags) |
1078
|
|
|
|
|
|
{ |
1079
|
|
|
|
|
|
char *namepv; |
1080
|
|
|
|
|
|
STRLEN namelen; |
1081
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_AUTOLOAD_SV; |
1082
|
10
|
50
|
|
|
|
namepv = SvPV(namesv, namelen); |
1083
|
10
|
100
|
|
|
|
if (SvUTF8(namesv)) |
1084
|
2
|
|
|
|
|
flags |= SVf_UTF8; |
1085
|
10
|
|
|
|
|
return gv_autoload_pvn(stash, namepv, namelen, flags); |
1086
|
|
|
|
|
|
} |
1087
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
GV* |
1089
|
8
|
|
|
|
|
Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags) |
1090
|
|
|
|
|
|
{ |
1091
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_AUTOLOAD_PV; |
1092
|
8
|
|
|
|
|
return gv_autoload_pvn(stash, namepv, strlen(namepv), flags); |
1093
|
|
|
|
|
|
} |
1094
|
|
|
|
|
|
|
1095
|
|
|
|
|
|
GV* |
1096
|
39028
|
|
|
|
|
Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) |
1097
|
|
|
|
|
|
{ |
1098
|
|
|
|
|
|
dVAR; |
1099
|
|
|
|
|
|
GV* gv; |
1100
|
|
|
|
|
|
CV* cv; |
1101
|
|
|
|
|
|
HV* varstash; |
1102
|
|
|
|
|
|
GV* vargv; |
1103
|
|
|
|
|
|
SV* varsv; |
1104
|
|
|
|
|
|
SV *packname = NULL; |
1105
|
39028
|
|
|
|
|
U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0; |
1106
|
|
|
|
|
|
|
1107
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN; |
1108
|
|
|
|
|
|
|
1109
|
39028
|
100
|
|
|
|
if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) |
|
|
50
|
|
|
|
|
1110
|
|
|
|
|
|
return NULL; |
1111
|
39028
|
100
|
|
|
|
if (stash) { |
1112
|
39020
|
100
|
|
|
|
if (SvTYPE(stash) < SVt_PVHV) { |
1113
|
22
|
|
|
|
|
STRLEN packname_len = 0; |
1114
|
22
|
50
|
|
|
|
const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len); |
1115
|
22
|
|
|
|
|
packname = newSVpvn_flags(packname_ptr, packname_len, |
1116
|
|
|
|
|
|
SVs_TEMP | SvUTF8(stash)); |
1117
|
|
|
|
|
|
stash = NULL; |
1118
|
|
|
|
|
|
} |
1119
|
|
|
|
|
|
else |
1120
|
38998
|
50
|
|
|
|
packname = sv_2mortal(newSVhek(HvNAME_HEK(stash))); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1121
|
39020
|
100
|
|
|
|
if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER"); |
1122
|
|
|
|
|
|
} |
1123
|
39028
|
100
|
|
|
|
if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, is_utf8))) |
1124
|
|
|
|
|
|
return NULL; |
1125
|
38110
|
|
|
|
|
cv = GvCV(gv); |
1126
|
|
|
|
|
|
|
1127
|
38110
|
100
|
|
|
|
if (!(CvROOT(cv) || CvXSUB(cv))) |
|
|
50
|
|
|
|
|
1128
|
|
|
|
|
|
return NULL; |
1129
|
|
|
|
|
|
|
1130
|
|
|
|
|
|
/* |
1131
|
|
|
|
|
|
* Inheriting AUTOLOAD for non-methods works ... for now. |
1132
|
|
|
|
|
|
*/ |
1133
|
38108
|
100
|
|
|
|
if ( |
1134
|
38108
|
|
|
|
|
!(flags & GV_AUTOLOAD_ISMETHOD) |
1135
|
10170
|
50
|
|
|
|
&& (GvCVGEN(gv) || GvSTASH(gv) != stash) |
|
|
100
|
|
|
|
|
1136
|
|
|
|
|
|
) |
1137
|
4
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), |
1138
|
|
|
|
|
|
"Use of inherited AUTOLOAD for non-method %"SVf |
1139
|
|
|
|
|
|
"::%"UTF8f"() is deprecated", |
1140
|
|
|
|
|
|
SVfARG(packname), |
1141
|
|
|
|
|
|
UTF8fARG(is_utf8, len, name)); |
1142
|
|
|
|
|
|
|
1143
|
38108
|
100
|
|
|
|
if (CvISXSUB(cv)) { |
1144
|
|
|
|
|
|
/* Instead of forcing the XSUB do another lookup for $AUTOLOAD |
1145
|
|
|
|
|
|
* and split that value on the last '::', pass along the same data |
1146
|
|
|
|
|
|
* via the SvPVX field in the CV, and the stash in CvSTASH. |
1147
|
|
|
|
|
|
* |
1148
|
|
|
|
|
|
* Due to an unfortunate accident of history, the SvPVX field |
1149
|
|
|
|
|
|
* serves two purposes. It is also used for the subroutine's pro- |
1150
|
|
|
|
|
|
* type. Since SvPVX has been documented as returning the sub name |
1151
|
|
|
|
|
|
* for a long time, but not as returning the prototype, we have |
1152
|
|
|
|
|
|
* to preserve the SvPVX AUTOLOAD behaviour and put the prototype |
1153
|
|
|
|
|
|
* elsewhere. |
1154
|
|
|
|
|
|
* |
1155
|
|
|
|
|
|
* We put the prototype in the same allocated buffer, but after |
1156
|
|
|
|
|
|
* the sub name. The SvPOK flag indicates the presence of a proto- |
1157
|
|
|
|
|
|
* type. The CvAUTOLOAD flag indicates the presence of a sub name. |
1158
|
|
|
|
|
|
* If both flags are on, then SvLEN is used to indicate the end of |
1159
|
|
|
|
|
|
* the prototype (artificially lower than what is actually allo- |
1160
|
|
|
|
|
|
* cated), at the risk of having to reallocate a few bytes unneces- |
1161
|
|
|
|
|
|
* sarily--but that should happen very rarely, if ever. |
1162
|
|
|
|
|
|
* |
1163
|
|
|
|
|
|
* We use SvUTF8 for both prototypes and sub names, so if one is |
1164
|
|
|
|
|
|
* UTF8, the other must be upgraded. |
1165
|
|
|
|
|
|
*/ |
1166
|
2354
|
|
|
|
|
CvSTASH_set(cv, stash); |
1167
|
2354
|
100
|
|
|
|
if (SvPOK(cv)) { /* Ouch! */ |
1168
|
14
|
|
|
|
|
SV * const tmpsv = newSVpvn_flags(name, len, is_utf8); |
1169
|
|
|
|
|
|
STRLEN ulen; |
1170
|
14
|
50
|
|
|
|
const char *proto = CvPROTO(cv); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
1171
|
|
|
|
|
|
assert(proto); |
1172
|
14
|
100
|
|
|
|
if (SvUTF8(cv)) |
1173
|
2
|
50
|
|
|
|
sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1174
|
14
|
|
|
|
|
ulen = SvCUR(tmpsv); |
1175
|
14
|
|
|
|
|
SvCUR(tmpsv)++; /* include null in string */ |
1176
|
14
|
100
|
|
|
|
sv_catpvn_flags( |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
1177
|
|
|
|
|
|
tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv) |
1178
|
|
|
|
|
|
); |
1179
|
14
|
|
|
|
|
SvTEMP_on(tmpsv); /* Allow theft */ |
1180
|
14
|
|
|
|
|
sv_setsv_nomg((SV *)cv, tmpsv); |
1181
|
14
|
|
|
|
|
SvTEMP_off(tmpsv); |
1182
|
14
|
|
|
|
|
SvREFCNT_dec_NN(tmpsv); |
1183
|
14
|
|
|
|
|
SvLEN(cv) = SvCUR(cv) + 1; |
1184
|
14
|
|
|
|
|
SvCUR(cv) = ulen; |
1185
|
|
|
|
|
|
} |
1186
|
|
|
|
|
|
else { |
1187
|
2340
|
|
|
|
|
sv_setpvn((SV *)cv, name, len); |
1188
|
2340
|
|
|
|
|
SvPOK_off(cv); |
1189
|
2340
|
100
|
|
|
|
if (is_utf8) |
1190
|
2
|
|
|
|
|
SvUTF8_on(cv); |
1191
|
2338
|
|
|
|
|
else SvUTF8_off(cv); |
1192
|
|
|
|
|
|
} |
1193
|
2354
|
|
|
|
|
CvAUTOLOAD_on(cv); |
1194
|
|
|
|
|
|
} |
1195
|
|
|
|
|
|
|
1196
|
|
|
|
|
|
/* |
1197
|
|
|
|
|
|
* Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. |
1198
|
|
|
|
|
|
* The subroutine's original name may not be "AUTOLOAD", so we don't |
1199
|
|
|
|
|
|
* use that, but for lack of anything better we will use the sub's |
1200
|
|
|
|
|
|
* original package to look up $AUTOLOAD. |
1201
|
|
|
|
|
|
*/ |
1202
|
38108
|
|
|
|
|
varstash = GvSTASH(CvGV(cv)); |
1203
|
38108
|
|
|
|
|
vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE); |
1204
|
38108
|
|
|
|
|
ENTER; |
1205
|
|
|
|
|
|
|
1206
|
38108
|
50
|
|
|
|
if (!isGV(vargv)) { |
1207
|
0
|
|
|
|
|
gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0); |
1208
|
|
|
|
|
|
#ifdef PERL_DONT_CREATE_GVSV |
1209
|
0
|
|
|
|
|
GvSV(vargv) = newSV(0); |
1210
|
|
|
|
|
|
#endif |
1211
|
|
|
|
|
|
} |
1212
|
38108
|
|
|
|
|
LEAVE; |
1213
|
38108
|
100
|
|
|
|
varsv = GvSVn(vargv); |
1214
|
38108
|
50
|
|
|
|
SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */ |
1215
|
|
|
|
|
|
/* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */ |
1216
|
38108
|
|
|
|
|
sv_setsv(varsv, packname); |
1217
|
38108
|
|
|
|
|
sv_catpvs(varsv, "::"); |
1218
|
|
|
|
|
|
/* Ensure SvSETMAGIC() is called if necessary. In particular, to clear |
1219
|
|
|
|
|
|
tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */ |
1220
|
38108
|
100
|
|
|
|
sv_catpvn_flags( |
1221
|
|
|
|
|
|
varsv, name, len, |
1222
|
|
|
|
|
|
SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES) |
1223
|
|
|
|
|
|
); |
1224
|
38108
|
100
|
|
|
|
if (is_utf8) |
1225
|
19881
|
|
|
|
|
SvUTF8_on(varsv); |
1226
|
|
|
|
|
|
return gv; |
1227
|
|
|
|
|
|
} |
1228
|
|
|
|
|
|
|
1229
|
|
|
|
|
|
|
1230
|
|
|
|
|
|
/* require_tie_mod() internal routine for requiring a module |
1231
|
|
|
|
|
|
* that implements the logic of automatic ties like %! and %- |
1232
|
|
|
|
|
|
* |
1233
|
|
|
|
|
|
* The "gv" parameter should be the glob. |
1234
|
|
|
|
|
|
* "varpv" holds the name of the var, used for error messages. |
1235
|
|
|
|
|
|
* "namesv" holds the module name. Its refcount will be decremented. |
1236
|
|
|
|
|
|
* "methpv" holds the method name to test for to check that things |
1237
|
|
|
|
|
|
* are working reasonably close to as expected. |
1238
|
|
|
|
|
|
* "flags": if flag & 1 then save the scalar before loading. |
1239
|
|
|
|
|
|
* For the protection of $! to work (it is set by this routine) |
1240
|
|
|
|
|
|
* the sv slot must already be magicalized. |
1241
|
|
|
|
|
|
*/ |
1242
|
|
|
|
|
|
STATIC HV* |
1243
|
23954
|
|
|
|
|
S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags) |
1244
|
|
|
|
|
|
{ |
1245
|
|
|
|
|
|
dVAR; |
1246
|
23954
|
|
|
|
|
HV* stash = gv_stashsv(namesv, 0); |
1247
|
|
|
|
|
|
|
1248
|
|
|
|
|
|
PERL_ARGS_ASSERT_REQUIRE_TIE_MOD; |
1249
|
|
|
|
|
|
|
1250
|
29366
|
100
|
|
|
|
if (!stash || !(gv_fetchmethod_autoload(stash, methpv, FALSE))) { |
|
|
100
|
|
|
|
|
1251
|
5518
|
|
|
|
|
SV *module = newSVsv(namesv); |
1252
|
5518
|
|
|
|
|
char varname = *varpv; /* varpv might be clobbered by load_module, |
1253
|
|
|
|
|
|
so save it. For the moment it's always |
1254
|
|
|
|
|
|
a single char. */ |
1255
|
5518
|
100
|
|
|
|
const char type = varname == '[' ? '$' : '%'; |
1256
|
5518
|
|
|
|
|
dSP; |
1257
|
5518
|
|
|
|
|
ENTER; |
1258
|
5518
|
|
|
|
|
SAVEFREESV(namesv); |
1259
|
5518
|
100
|
|
|
|
if ( flags & 1 ) |
1260
|
4376
|
|
|
|
|
save_scalar(gv); |
1261
|
5518
|
100
|
|
|
|
PUSHSTACKi(PERLSI_MAGIC); |
1262
|
5518
|
|
|
|
|
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); |
1263
|
5416
|
50
|
|
|
|
POPSTACK; |
1264
|
5416
|
|
|
|
|
stash = gv_stashsv(namesv, 0); |
1265
|
5416
|
100
|
|
|
|
if (!stash) |
1266
|
4
|
|
|
|
|
Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available", |
1267
|
|
|
|
|
|
type, varname, SVfARG(namesv)); |
1268
|
5412
|
50
|
|
|
|
else if (!gv_fetchmethod(stash, methpv)) |
1269
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s", |
1270
|
|
|
|
|
|
type, varname, SVfARG(namesv), methpv); |
1271
|
5412
|
|
|
|
|
LEAVE; |
1272
|
|
|
|
|
|
} |
1273
|
18436
|
|
|
|
|
else SvREFCNT_dec_NN(namesv); |
1274
|
23848
|
|
|
|
|
return stash; |
1275
|
|
|
|
|
|
} |
1276
|
|
|
|
|
|
|
1277
|
|
|
|
|
|
/* |
1278
|
|
|
|
|
|
=for apidoc gv_stashpv |
1279
|
|
|
|
|
|
|
1280
|
|
|
|
|
|
Returns a pointer to the stash for a specified package. Uses C to |
1281
|
|
|
|
|
|
determine the length of C, then calls C. |
1282
|
|
|
|
|
|
|
1283
|
|
|
|
|
|
=cut |
1284
|
|
|
|
|
|
*/ |
1285
|
|
|
|
|
|
|
1286
|
|
|
|
|
|
HV* |
1287
|
469819637
|
|
|
|
|
Perl_gv_stashpv(pTHX_ const char *name, I32 create) |
1288
|
|
|
|
|
|
{ |
1289
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_STASHPV; |
1290
|
469819637
|
|
|
|
|
return gv_stashpvn(name, strlen(name), create); |
1291
|
|
|
|
|
|
} |
1292
|
|
|
|
|
|
|
1293
|
|
|
|
|
|
/* |
1294
|
|
|
|
|
|
=for apidoc gv_stashpvn |
1295
|
|
|
|
|
|
|
1296
|
|
|
|
|
|
Returns a pointer to the stash for a specified package. The C |
1297
|
|
|
|
|
|
parameter indicates the length of the C, in bytes. C is passed |
1298
|
|
|
|
|
|
to C, so if set to C then the package will be |
1299
|
|
|
|
|
|
created if it does not already exist. If the package does not exist and |
1300
|
|
|
|
|
|
C is 0 (or any other setting that does not create packages) then NULL |
1301
|
|
|
|
|
|
is returned. |
1302
|
|
|
|
|
|
|
1303
|
|
|
|
|
|
Flags may be one of: |
1304
|
|
|
|
|
|
|
1305
|
|
|
|
|
|
GV_ADD |
1306
|
|
|
|
|
|
SVf_UTF8 |
1307
|
|
|
|
|
|
GV_NOADD_NOINIT |
1308
|
|
|
|
|
|
GV_NOINIT |
1309
|
|
|
|
|
|
GV_NOEXPAND |
1310
|
|
|
|
|
|
GV_ADDMG |
1311
|
|
|
|
|
|
|
1312
|
|
|
|
|
|
The most important of which are probably GV_ADD and SVf_UTF8. |
1313
|
|
|
|
|
|
|
1314
|
|
|
|
|
|
=cut |
1315
|
|
|
|
|
|
*/ |
1316
|
|
|
|
|
|
|
1317
|
|
|
|
|
|
HV* |
1318
|
587694165
|
|
|
|
|
Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) |
1319
|
|
|
|
|
|
{ |
1320
|
|
|
|
|
|
char smallbuf[128]; |
1321
|
|
|
|
|
|
char *tmpbuf; |
1322
|
|
|
|
|
|
HV *stash; |
1323
|
|
|
|
|
|
GV *tmpgv; |
1324
|
587694165
|
|
|
|
|
U32 tmplen = namelen + 2; |
1325
|
|
|
|
|
|
|
1326
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_STASHPVN; |
1327
|
|
|
|
|
|
|
1328
|
587694165
|
100
|
|
|
|
if (tmplen <= sizeof smallbuf) |
1329
|
|
|
|
|
|
tmpbuf = smallbuf; |
1330
|
|
|
|
|
|
else |
1331
|
254
|
|
|
|
|
Newx(tmpbuf, tmplen, char); |
1332
|
587694165
|
|
|
|
|
Copy(name, tmpbuf, namelen, char); |
1333
|
587694165
|
|
|
|
|
tmpbuf[namelen] = ':'; |
1334
|
587694165
|
|
|
|
|
tmpbuf[namelen+1] = ':'; |
1335
|
587694165
|
|
|
|
|
tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV); |
1336
|
587694165
|
100
|
|
|
|
if (tmpbuf != smallbuf) |
1337
|
254
|
|
|
|
|
Safefree(tmpbuf); |
1338
|
587694165
|
100
|
|
|
|
if (!tmpgv) |
1339
|
|
|
|
|
|
return NULL; |
1340
|
587376741
|
|
|
|
|
stash = GvHV(tmpgv); |
1341
|
587376741
|
100
|
|
|
|
if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL; |
1342
|
|
|
|
|
|
assert(stash); |
1343
|
587376739
|
100
|
|
|
|
if (!HvNAME_get(stash)) { |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
1344
|
24
|
|
|
|
|
hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 ); |
1345
|
|
|
|
|
|
|
1346
|
|
|
|
|
|
/* FIXME: This is a repeat of logic in gv_fetchpvn_flags */ |
1347
|
|
|
|
|
|
/* If the containing stash has multiple effective |
1348
|
|
|
|
|
|
names, see that this one gets them, too. */ |
1349
|
24
|
100
|
|
|
|
if (HvAUX(GvSTASH(tmpgv))->xhv_name_count) |
1350
|
294033475
|
|
|
|
|
mro_package_moved(stash, NULL, tmpgv, 1); |
1351
|
|
|
|
|
|
} |
1352
|
|
|
|
|
|
return stash; |
1353
|
|
|
|
|
|
} |
1354
|
|
|
|
|
|
|
1355
|
|
|
|
|
|
/* |
1356
|
|
|
|
|
|
=for apidoc gv_stashsv |
1357
|
|
|
|
|
|
|
1358
|
|
|
|
|
|
Returns a pointer to the stash for a specified package. See C. |
1359
|
|
|
|
|
|
|
1360
|
|
|
|
|
|
=cut |
1361
|
|
|
|
|
|
*/ |
1362
|
|
|
|
|
|
|
1363
|
|
|
|
|
|
HV* |
1364
|
86599078
|
|
|
|
|
Perl_gv_stashsv(pTHX_ SV *sv, I32 flags) |
1365
|
|
|
|
|
|
{ |
1366
|
|
|
|
|
|
STRLEN len; |
1367
|
86599078
|
100
|
|
|
|
const char * const ptr = SvPV_const(sv,len); |
1368
|
|
|
|
|
|
|
1369
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_STASHSV; |
1370
|
|
|
|
|
|
|
1371
|
86599078
|
|
|
|
|
return gv_stashpvn(ptr, len, flags | SvUTF8(sv)); |
1372
|
|
|
|
|
|
} |
1373
|
|
|
|
|
|
|
1374
|
|
|
|
|
|
|
1375
|
|
|
|
|
|
GV * |
1376
|
216167413
|
|
|
|
|
Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) { |
1377
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_FETCHPV; |
1378
|
216167413
|
|
|
|
|
return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type); |
1379
|
|
|
|
|
|
} |
1380
|
|
|
|
|
|
|
1381
|
|
|
|
|
|
GV * |
1382
|
113762471
|
|
|
|
|
Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) { |
1383
|
|
|
|
|
|
STRLEN len; |
1384
|
|
|
|
|
|
const char * const nambeg = |
1385
|
113762471
|
100
|
|
|
|
SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC); |
|
|
100
|
|
|
|
|
1386
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_FETCHSV; |
1387
|
113762471
|
|
|
|
|
return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type); |
1388
|
|
|
|
|
|
} |
1389
|
|
|
|
|
|
|
1390
|
|
|
|
|
|
STATIC void |
1391
|
447134
|
|
|
|
|
S_gv_magicalize_isa(pTHX_ GV *gv) |
1392
|
|
|
|
|
|
{ |
1393
|
|
|
|
|
|
AV* av; |
1394
|
|
|
|
|
|
|
1395
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA; |
1396
|
|
|
|
|
|
|
1397
|
447134
|
50
|
|
|
|
av = GvAVn(gv); |
1398
|
447134
|
|
|
|
|
GvMULTI_on(gv); |
1399
|
447134
|
|
|
|
|
sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa, |
1400
|
|
|
|
|
|
NULL, 0); |
1401
|
447134
|
|
|
|
|
} |
1402
|
|
|
|
|
|
|
1403
|
|
|
|
|
|
GV * |
1404
|
1001020195
|
|
|
|
|
Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, |
1405
|
|
|
|
|
|
const svtype sv_type) |
1406
|
|
|
|
|
|
{ |
1407
|
|
|
|
|
|
dVAR; |
1408
|
|
|
|
|
|
const char *name = nambeg; |
1409
|
|
|
|
|
|
GV *gv = NULL; |
1410
|
|
|
|
|
|
GV**gvp; |
1411
|
|
|
|
|
|
STRLEN len; |
1412
|
|
|
|
|
|
const char *name_cursor; |
1413
|
|
|
|
|
|
HV *stash = NULL; |
1414
|
1001020195
|
|
|
|
|
const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT); |
1415
|
1001020195
|
|
|
|
|
const I32 no_expand = flags & GV_NOEXPAND; |
1416
|
1001020195
|
|
|
|
|
const I32 add = flags & ~GV_NOADD_MASK; |
1417
|
1001020195
|
|
|
|
|
const U32 is_utf8 = flags & SVf_UTF8; |
1418
|
1001020195
|
|
|
|
|
bool addmg = !!(flags & GV_ADDMG); |
1419
|
1001020195
|
|
|
|
|
const char *const name_end = nambeg + full_len; |
1420
|
1001020195
|
|
|
|
|
const char *const name_em1 = name_end - 1; |
1421
|
|
|
|
|
|
U32 faking_it; |
1422
|
|
|
|
|
|
|
1423
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS; |
1424
|
|
|
|
|
|
|
1425
|
1001020195
|
100
|
|
|
|
if (flags & GV_NOTQUAL) { |
1426
|
|
|
|
|
|
/* Caller promised that there is no stash, so we can skip the check. */ |
1427
|
|
|
|
|
|
len = full_len; |
1428
|
|
|
|
|
|
goto no_stash; |
1429
|
|
|
|
|
|
} |
1430
|
|
|
|
|
|
|
1431
|
993973298
|
100
|
|
|
|
if (full_len > 2 && *name == '*' && isIDFIRST_lazy_if(name + 1, is_utf8)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
1432
|
|
|
|
|
|
/* accidental stringify on a GV? */ |
1433
|
30573908
|
|
|
|
|
name++; |
1434
|
|
|
|
|
|
} |
1435
|
|
|
|
|
|
|
1436
|
8733801686
|
100
|
|
|
|
for (name_cursor = name; name_cursor < name_end; name_cursor++) { |
1437
|
12290728444
|
100
|
|
|
|
if (name_cursor < name_em1 && |
|
|
100
|
|
|
|
|
1438
|
7941053554
|
|
|
|
|
((*name_cursor == ':' |
1439
|
1565107791
|
100
|
|
|
|
&& name_cursor[1] == ':') |
1440
|
6375949635
|
100
|
|
|
|
|| *name_cursor == '\'')) |
1441
|
|
|
|
|
|
{ |
1442
|
1565103991
|
100
|
|
|
|
if (!stash) |
1443
|
880303638
|
|
|
|
|
stash = PL_defstash; |
1444
|
1565103991
|
50
|
|
|
|
if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */ |
|
|
50
|
|
|
|
|
1445
|
|
|
|
|
|
return NULL; |
1446
|
|
|
|
|
|
|
1447
|
1565103991
|
|
|
|
|
len = name_cursor - name; |
1448
|
1565103991
|
100
|
|
|
|
if (name_cursor > nambeg) { /* Skip for initial :: or ' */ |
1449
|
|
|
|
|
|
const char *key; |
1450
|
1564966125
|
100
|
|
|
|
if (*name_cursor == ':') { |
1451
|
|
|
|
|
|
key = name; |
1452
|
1564966055
|
|
|
|
|
len += 2; |
1453
|
|
|
|
|
|
} else { |
1454
|
|
|
|
|
|
char *tmpbuf; |
1455
|
70
|
|
|
|
|
Newx(tmpbuf, len+2, char); |
1456
|
70
|
|
|
|
|
Copy(name, tmpbuf, len, char); |
1457
|
70
|
|
|
|
|
tmpbuf[len++] = ':'; |
1458
|
70
|
|
|
|
|
tmpbuf[len++] = ':'; |
1459
|
|
|
|
|
|
key = tmpbuf; |
1460
|
|
|
|
|
|
} |
1461
|
1564966125
|
100
|
|
|
|
gvp = (GV**)hv_fetch(stash, key, is_utf8 ? -len : len, add); |
|
|
100
|
|
|
|
|
1462
|
1564966125
|
100
|
|
|
|
gv = gvp ? *gvp : NULL; |
1463
|
1564966125
|
100
|
|
|
|
if (gv && gv != (const GV *)&PL_sv_undef) { |
|
|
50
|
|
|
|
|
1464
|
1564615731
|
100
|
|
|
|
if (SvTYPE(gv) != SVt_PVGV) |
1465
|
1600285
|
|
|
|
|
gv_init_pvn(gv, stash, key, len, (add & GV_ADDMULTI)|is_utf8); |
1466
|
|
|
|
|
|
else |
1467
|
1563015446
|
|
|
|
|
GvMULTI_on(gv); |
1468
|
|
|
|
|
|
} |
1469
|
1564966125
|
100
|
|
|
|
if (key != name) |
1470
|
70
|
|
|
|
|
Safefree(key); |
1471
|
1564966125
|
100
|
|
|
|
if (!gv || gv == (const GV *)&PL_sv_undef) |
|
|
50
|
|
|
|
|
1472
|
|
|
|
|
|
return NULL; |
1473
|
|
|
|
|
|
|
1474
|
1564615731
|
100
|
|
|
|
if (!(stash = GvHV(gv))) |
1475
|
|
|
|
|
|
{ |
1476
|
1600303
|
|
|
|
|
stash = GvHV(gv) = newHV(); |
1477
|
1600303
|
50
|
|
|
|
if (!HvNAME_get(stash)) { |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
1478
|
1600303
|
100
|
|
|
|
if (GvSTASH(gv) == PL_defstash && len == 6 |
1479
|
172462
|
100
|
|
|
|
&& strnEQ(name, "CORE", 4)) |
1480
|
24346
|
|
|
|
|
hv_name_set(stash, "CORE", 4, 0); |
1481
|
|
|
|
|
|
else |
1482
|
1575957
|
|
|
|
|
hv_name_set( |
1483
|
|
|
|
|
|
stash, nambeg, name_cursor-nambeg, is_utf8 |
1484
|
|
|
|
|
|
); |
1485
|
|
|
|
|
|
/* If the containing stash has multiple effective |
1486
|
|
|
|
|
|
names, see that this one gets them, too. */ |
1487
|
1600303
|
100
|
|
|
|
if (HvAUX(GvSTASH(gv))->xhv_name_count) |
1488
|
190
|
|
|
|
|
mro_package_moved(stash, NULL, gv, 1); |
1489
|
|
|
|
|
|
} |
1490
|
|
|
|
|
|
} |
1491
|
1563015428
|
100
|
|
|
|
else if (!HvNAME_get(stash)) |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
1492
|
48
|
|
|
|
|
hv_name_set(stash, nambeg, name_cursor - nambeg, is_utf8); |
1493
|
|
|
|
|
|
} |
1494
|
|
|
|
|
|
|
1495
|
1564753597
|
100
|
|
|
|
if (*name_cursor == ':') |
1496
|
1564753529
|
|
|
|
|
name_cursor++; |
1497
|
1564753597
|
|
|
|
|
name = name_cursor+1; |
1498
|
1564753597
|
100
|
|
|
|
if (name == name_end) |
1499
|
597234767
|
|
|
|
|
return gv |
1500
|
597234767
|
100
|
|
|
|
? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE)); |
1501
|
|
|
|
|
|
} |
1502
|
|
|
|
|
|
} |
1503
|
396388137
|
|
|
|
|
len = name_cursor - name; |
1504
|
|
|
|
|
|
|
1505
|
|
|
|
|
|
/* No stash in name, so see how we can default */ |
1506
|
|
|
|
|
|
|
1507
|
396388137
|
100
|
|
|
|
if (!stash) { |
1508
|
|
|
|
|
|
no_stash: |
1509
|
120716557
|
100
|
|
|
|
if (len && isIDFIRST_lazy_if(name, is_utf8)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1510
|
|
|
|
|
|
bool global = FALSE; |
1511
|
|
|
|
|
|
|
1512
|
108256987
|
|
|
|
|
switch (len) { |
1513
|
|
|
|
|
|
case 1: |
1514
|
24041368
|
100
|
|
|
|
if (*name == '_') |
1515
|
|
|
|
|
|
global = TRUE; |
1516
|
|
|
|
|
|
break; |
1517
|
|
|
|
|
|
case 3: |
1518
|
7740322
|
100
|
|
|
|
if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C') |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
1519
|
7318506
|
100
|
|
|
|
|| (name[0] == 'E' && name[1] == 'N' && name[2] == 'V') |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1520
|
6626553
|
100
|
|
|
|
|| (name[0] == 'S' && name[1] == 'I' && name[2] == 'G')) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
1521
|
|
|
|
|
|
global = TRUE; |
1522
|
|
|
|
|
|
break; |
1523
|
|
|
|
|
|
case 4: |
1524
|
9395079
|
100
|
|
|
|
if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
1525
|
167734
|
100
|
|
|
|
&& name[3] == 'V') |
1526
|
|
|
|
|
|
global = TRUE; |
1527
|
|
|
|
|
|
break; |
1528
|
|
|
|
|
|
case 5: |
1529
|
15107199
|
100
|
|
|
|
if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D' |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1530
|
56152
|
50
|
|
|
|
&& name[3] == 'I' && name[4] == 'N') |
|
|
50
|
|
|
|
|
1531
|
|
|
|
|
|
global = TRUE; |
1532
|
|
|
|
|
|
break; |
1533
|
|
|
|
|
|
case 6: |
1534
|
10316484
|
100
|
|
|
|
if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D') |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1535
|
962572
|
100
|
|
|
|
&&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T') |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1536
|
883899
|
50
|
|
|
|
||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R'))) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1537
|
|
|
|
|
|
global = TRUE; |
1538
|
|
|
|
|
|
break; |
1539
|
|
|
|
|
|
case 7: |
1540
|
12678201
|
100
|
|
|
|
if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
1541
|
316
|
100
|
|
|
|
&& name[3] == 'V' && name[4] == 'O' && name[5] == 'U' |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1542
|
216
|
50
|
|
|
|
&& name[6] == 'T') |
1543
|
|
|
|
|
|
global = TRUE; |
1544
|
|
|
|
|
|
break; |
1545
|
|
|
|
|
|
} |
1546
|
|
|
|
|
|
|
1547
|
108256987
|
100
|
|
|
|
if (global) |
1548
|
27168232
|
|
|
|
|
stash = PL_defstash; |
1549
|
81088755
|
100
|
|
|
|
else if (IN_PERL_COMPILETIME) { |
1550
|
79755158
|
|
|
|
|
stash = PL_curstash; |
1551
|
100932867
|
100
|
|
|
|
if (add && (PL_hints & HINT_STRICT_VARS) && |
|
|
100
|
|
|
|
|
1552
|
43520925
|
|
|
|
|
sv_type != SVt_PVCV && |
1553
|
4093893
|
100
|
|
|
|
sv_type != SVt_PVGV && |
1554
|
3500204
|
100
|
|
|
|
sv_type != SVt_PVFM && |
1555
|
1906654
|
100
|
|
|
|
sv_type != SVt_PVIO && |
1556
|
1156055
|
100
|
|
|
|
!(len == 1 && sv_type == SVt_PV && |
1557
|
263568
|
|
|
|
|
(*name == 'a' || *name == 'b')) ) |
1558
|
|
|
|
|
|
{ |
1559
|
1716488
|
100
|
|
|
|
gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,0); |
1560
|
2517812
|
100
|
|
|
|
if (!gvp || |
|
|
50
|
|
|
|
|
1561
|
2517732
|
50
|
|
|
|
*gvp == (const GV *)&PL_sv_undef || |
1562
|
1716408
|
|
|
|
|
SvTYPE(*gvp) != SVt_PVGV) |
1563
|
|
|
|
|
|
{ |
1564
|
|
|
|
|
|
stash = NULL; |
1565
|
|
|
|
|
|
} |
1566
|
1716408
|
100
|
|
|
|
else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) || |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1567
|
990937
|
100
|
|
|
|
(sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) || |
|
|
100
|
|
|
|
|
1568
|
364462
|
100
|
|
|
|
(sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) ) |
1569
|
|
|
|
|
|
{ |
1570
|
|
|
|
|
|
/* diag_listed_as: Variable "%s" is not imported%s */ |
1571
|
319
|
100
|
|
|
|
Perl_ck_warner_d( |
1572
|
|
|
|
|
|
aTHX_ packWARN(WARN_MISC), |
1573
|
|
|
|
|
|
"Variable \"%c%"UTF8f"\" is not imported", |
1574
|
|
|
|
|
|
sv_type == SVt_PVAV ? '@' : |
1575
|
158
|
100
|
|
|
|
sv_type == SVt_PVHV ? '%' : '$', |
1576
|
|
|
|
|
|
UTF8fARG(is_utf8, len, name)); |
1577
|
160
|
50
|
|
|
|
if (GvCVu(*gvp)) |
|
|
50
|
|
|
|
|
1578
|
0
|
|
|
|
|
Perl_ck_warner_d( |
1579
|
|
|
|
|
|
aTHX_ packWARN(WARN_MISC), |
1580
|
|
|
|
|
|
"\t(Did you mean &%"UTF8f" instead?)\n", |
1581
|
|
|
|
|
|
UTF8fARG(is_utf8, len, name) |
1582
|
|
|
|
|
|
); |
1583
|
|
|
|
|
|
stash = NULL; |
1584
|
|
|
|
|
|
} |
1585
|
|
|
|
|
|
} |
1586
|
|
|
|
|
|
} |
1587
|
|
|
|
|
|
else |
1588
|
1333597
|
|
|
|
|
stash = CopSTASH(PL_curcop); |
1589
|
|
|
|
|
|
} |
1590
|
|
|
|
|
|
else |
1591
|
12459570
|
|
|
|
|
stash = PL_defstash; |
1592
|
|
|
|
|
|
} |
1593
|
|
|
|
|
|
|
1594
|
|
|
|
|
|
/* By this point we should have a stash and a name */ |
1595
|
|
|
|
|
|
|
1596
|
403435034
|
100
|
|
|
|
if (!stash) { |
1597
|
486
|
100
|
|
|
|
if (add && !PL_in_clean_all) { |
|
|
50
|
|
|
|
|
1598
|
367
|
100
|
|
|
|
SV * const err = Perl_mess(aTHX_ |
1599
|
|
|
|
|
|
"Global symbol \"%s%"UTF8f |
1600
|
|
|
|
|
|
"\" requires explicit package name", |
1601
|
|
|
|
|
|
(sv_type == SVt_PV ? "$" |
1602
|
|
|
|
|
|
: sv_type == SVt_PVAV ? "@" |
1603
|
8
|
100
|
|
|
|
: sv_type == SVt_PVHV ? "%" |
1604
|
5
|
50
|
|
|
|
: ""), UTF8fARG(is_utf8, len, name)); |
1605
|
|
|
|
|
|
GV *gv; |
1606
|
242
|
100
|
|
|
|
if (is_utf8) |
1607
|
144
|
|
|
|
|
SvUTF8_on(err); |
1608
|
242
|
|
|
|
|
qerror(err); |
1609
|
242
|
|
|
|
|
gv = gv_fetchpvs("::", GV_ADDMULTI, SVt_PVHV); |
1610
|
242
|
50
|
|
|
|
if(!gv) { |
1611
|
|
|
|
|
|
/* symbol table under destruction */ |
1612
|
|
|
|
|
|
return NULL; |
1613
|
|
|
|
|
|
} |
1614
|
242
|
|
|
|
|
stash = GvHV(gv); |
1615
|
|
|
|
|
|
} |
1616
|
|
|
|
|
|
else |
1617
|
|
|
|
|
|
return NULL; |
1618
|
|
|
|
|
|
} |
1619
|
|
|
|
|
|
|
1620
|
403435032
|
50
|
|
|
|
if (!SvREFCNT(stash)) /* symbol table under destruction */ |
1621
|
|
|
|
|
|
return NULL; |
1622
|
|
|
|
|
|
|
1623
|
403435032
|
100
|
|
|
|
gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add); |
|
|
100
|
|
|
|
|
1624
|
403435032
|
100
|
|
|
|
if (!gvp || *gvp == (const GV *)&PL_sv_undef) { |
|
|
50
|
|
|
|
|
1625
|
31357133
|
100
|
|
|
|
if (addmg) gv = (GV *)newSV(0); |
1626
|
|
|
|
|
|
else return NULL; |
1627
|
|
|
|
|
|
} |
1628
|
372077899
|
|
|
|
|
else gv = *gvp, addmg = 0; |
1629
|
|
|
|
|
|
/* From this point on, addmg means gv has not been inserted in the |
1630
|
|
|
|
|
|
symtab yet. */ |
1631
|
|
|
|
|
|
|
1632
|
372431671
|
100
|
|
|
|
if (SvTYPE(gv) == SVt_PVGV) { |
1633
|
343715265
|
100
|
|
|
|
if (add) { |
1634
|
91576626
|
|
|
|
|
GvMULTI_on(gv); |
1635
|
91576626
|
|
|
|
|
gv_init_svtype(gv, sv_type); |
1636
|
|
|
|
|
|
/* You reach this path once the typeglob has already been created, |
1637
|
|
|
|
|
|
either by the same or a different sigil. If this path didn't |
1638
|
|
|
|
|
|
exist, then (say) referencing $! first, and %! second would |
1639
|
|
|
|
|
|
mean that %! was not handled correctly. */ |
1640
|
91576626
|
100
|
|
|
|
if (len == 1 && stash == PL_defstash) { |
|
|
100
|
|
|
|
|
1641
|
16933283
|
100
|
|
|
|
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) { |
1642
|
474697
|
100
|
|
|
|
if (*name == '!') |
1643
|
16282
|
|
|
|
|
require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); |
1644
|
458415
|
100
|
|
|
|
else if (*name == '-' || *name == '+') |
1645
|
6002
|
|
|
|
|
require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); |
1646
|
16458586
|
100
|
|
|
|
} else if (sv_type == SVt_PV) { |
1647
|
7394894
|
100
|
|
|
|
if (*name == '*' || *name == '#') { |
1648
|
|
|
|
|
|
/* diag_listed_as: $* is no longer supported */ |
1649
|
34
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, |
1650
|
|
|
|
|
|
WARN_SYNTAX), |
1651
|
34
|
|
|
|
|
"$%c is no longer supported", *name); |
1652
|
|
|
|
|
|
} |
1653
|
|
|
|
|
|
} |
1654
|
16933177
|
100
|
|
|
|
if (sv_type==SVt_PV || sv_type==SVt_PVGV) { |
1655
|
7670891
|
100
|
|
|
|
switch (*name) { |
1656
|
|
|
|
|
|
case '[': |
1657
|
630
|
|
|
|
|
require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0); |
1658
|
630
|
|
|
|
|
break; |
1659
|
|
|
|
|
|
#ifdef PERL_SAWAMPERSAND |
1660
|
|
|
|
|
|
case '`': |
1661
|
|
|
|
|
|
PL_sawampersand |= SAWAMPERSAND_LEFT; |
1662
|
|
|
|
|
|
(void)GvSVn(gv); |
1663
|
|
|
|
|
|
break; |
1664
|
|
|
|
|
|
case '&': |
1665
|
|
|
|
|
|
PL_sawampersand |= SAWAMPERSAND_MIDDLE; |
1666
|
|
|
|
|
|
(void)GvSVn(gv); |
1667
|
|
|
|
|
|
break; |
1668
|
|
|
|
|
|
case '\'': |
1669
|
|
|
|
|
|
PL_sawampersand |= SAWAMPERSAND_RIGHT; |
1670
|
|
|
|
|
|
(void)GvSVn(gv); |
1671
|
|
|
|
|
|
break; |
1672
|
|
|
|
|
|
#endif |
1673
|
|
|
|
|
|
} |
1674
|
|
|
|
|
|
} |
1675
|
|
|
|
|
|
} |
1676
|
74643343
|
100
|
|
|
|
else if (len == 3 && sv_type == SVt_PVAV |
1677
|
327410
|
100
|
|
|
|
&& strnEQ(name, "ISA", 3) |
1678
|
128195
|
50
|
|
|
|
&& (!GvAV(gv) || !SvSMAGICAL(GvAV(gv)))) |
|
|
50
|
|
|
|
|
1679
|
0
|
|
|
|
|
gv_magicalize_isa(gv); |
1680
|
|
|
|
|
|
} |
1681
|
|
|
|
|
|
return gv; |
1682
|
28716406
|
100
|
|
|
|
} else if (no_init) { |
1683
|
|
|
|
|
|
assert(!addmg); |
1684
|
|
|
|
|
|
return gv; |
1685
|
26242792
|
100
|
|
|
|
} else if (no_expand && SvROK(gv)) { |
|
|
100
|
|
|
|
|
1686
|
|
|
|
|
|
assert(!addmg); |
1687
|
|
|
|
|
|
return gv; |
1688
|
|
|
|
|
|
} |
1689
|
|
|
|
|
|
|
1690
|
|
|
|
|
|
/* Adding a new symbol. |
1691
|
|
|
|
|
|
Unless of course there was already something non-GV here, in which case |
1692
|
|
|
|
|
|
we want to behave as if there was always a GV here, containing some sort |
1693
|
|
|
|
|
|
of subroutine. |
1694
|
|
|
|
|
|
Otherwise we run the risk of creating things like GvIO, which can cause |
1695
|
|
|
|
|
|
subtle bugs. eg the one that tripped up SQL::Translator */ |
1696
|
|
|
|
|
|
|
1697
|
25559034
|
100
|
|
|
|
faking_it = SvOK(gv); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1698
|
|
|
|
|
|
|
1699
|
25559034
|
50
|
|
|
|
if (add & GV_ADDWARN) |
1700
|
0
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), |
1701
|
|
|
|
|
|
"Had to create %"UTF8f" unexpectedly", |
1702
|
0
|
|
|
|
|
UTF8fARG(is_utf8, name_end-nambeg, nambeg)); |
1703
|
25559034
|
|
|
|
|
gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8); |
1704
|
|
|
|
|
|
|
1705
|
50407988
|
100
|
|
|
|
if ( isIDFIRST_lazy_if(name, is_utf8) |
1706
|
62586402
|
100
|
|
|
|
&& ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) ) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1707
|
17422226
|
|
|
|
|
GvMULTI_on(gv) ; |
1708
|
|
|
|
|
|
|
1709
|
|
|
|
|
|
/* set up magic where warranted */ |
1710
|
25559014
|
100
|
|
|
|
if (stash != PL_defstash) { /* not the main stash */ |
1711
|
|
|
|
|
|
/* We only have to check for three names here: EXPORT, ISA |
1712
|
|
|
|
|
|
and VERSION. All the others apply only to the main stash or to |
1713
|
|
|
|
|
|
CORE (which is checked right after this). */ |
1714
|
24357756
|
100
|
|
|
|
if (len > 2) { |
1715
|
23851477
|
|
|
|
|
const char * const name2 = name + 1; |
1716
|
23851477
|
|
|
|
|
switch (*name) { |
1717
|
|
|
|
|
|
case 'E': |
1718
|
1134123
|
100
|
|
|
|
if (strnEQ(name2, "XPORT", 5)) |
1719
|
363726
|
|
|
|
|
GvMULTI_on(gv); |
1720
|
|
|
|
|
|
break; |
1721
|
|
|
|
|
|
case 'I': |
1722
|
682506
|
100
|
|
|
|
if (strEQ(name2, "SA")) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1723
|
447090
|
|
|
|
|
gv_magicalize_isa(gv); |
1724
|
|
|
|
|
|
break; |
1725
|
|
|
|
|
|
case 'V': |
1726
|
665063
|
100
|
|
|
|
if (strEQ(name2, "ERSION")) |
1727
|
586999
|
|
|
|
|
GvMULTI_on(gv); |
1728
|
|
|
|
|
|
break; |
1729
|
|
|
|
|
|
default: |
1730
|
|
|
|
|
|
goto try_core; |
1731
|
|
|
|
|
|
} |
1732
|
|
|
|
|
|
goto add_magical_gv; |
1733
|
|
|
|
|
|
} |
1734
|
|
|
|
|
|
try_core: |
1735
|
21876064
|
100
|
|
|
|
if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1736
|
|
|
|
|
|
/* Avoid null warning: */ |
1737
|
1679588
|
50
|
|
|
|
const char * const stashname = HvNAME(stash); assert(stashname); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
1738
|
1679588
|
100
|
|
|
|
if (strnEQ(stashname, "CORE", 4)) |
1739
|
926
|
|
|
|
|
S_maybe_add_coresub(aTHX_ 0, gv, name, len); |
1740
|
|
|
|
|
|
} |
1741
|
|
|
|
|
|
} |
1742
|
1201258
|
100
|
|
|
|
else if (len > 1) { |
1743
|
|
|
|
|
|
#ifndef EBCDIC |
1744
|
709688
|
100
|
|
|
|
if (*name > 'V' ) { |
1745
|
|
|
|
|
|
NOOP; |
1746
|
|
|
|
|
|
/* Nothing else to do. |
1747
|
|
|
|
|
|
The compiler will probably turn the switch statement into a |
1748
|
|
|
|
|
|
branch table. Make sure we avoid even that small overhead for |
1749
|
|
|
|
|
|
the common case of lower case variable names. (On EBCDIC |
1750
|
|
|
|
|
|
platforms, we can't just do: |
1751
|
|
|
|
|
|
if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) { |
1752
|
|
|
|
|
|
because cases like '\027' in the switch statement below are |
1753
|
|
|
|
|
|
C1 (non-ASCII) controls on those platforms, so the remapping |
1754
|
|
|
|
|
|
would make them larger than 'V') |
1755
|
|
|
|
|
|
*/ |
1756
|
|
|
|
|
|
} else |
1757
|
|
|
|
|
|
#endif |
1758
|
|
|
|
|
|
{ |
1759
|
308756
|
|
|
|
|
const char * const name2 = name + 1; |
1760
|
308756
|
|
|
|
|
switch (*name) { |
1761
|
|
|
|
|
|
case 'A': |
1762
|
32008
|
100
|
|
|
|
if (strEQ(name2, "RGV")) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1763
|
24228
|
50
|
|
|
|
IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1764
|
|
|
|
|
|
} |
1765
|
7780
|
100
|
|
|
|
else if (strEQ(name2, "RGVOUT")) { |
1766
|
212
|
|
|
|
|
GvMULTI_on(gv); |
1767
|
|
|
|
|
|
} |
1768
|
|
|
|
|
|
break; |
1769
|
|
|
|
|
|
case 'E': |
1770
|
27932
|
50
|
|
|
|
if (strnEQ(name2, "XPORT", 5)) |
1771
|
0
|
|
|
|
|
GvMULTI_on(gv); |
1772
|
|
|
|
|
|
break; |
1773
|
|
|
|
|
|
case 'I': |
1774
|
28762
|
100
|
|
|
|
if (strEQ(name2, "SA")) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1775
|
44
|
|
|
|
|
gv_magicalize_isa(gv); |
1776
|
|
|
|
|
|
} |
1777
|
|
|
|
|
|
break; |
1778
|
|
|
|
|
|
case 'S': |
1779
|
93930
|
100
|
|
|
|
if (strEQ(name2, "IG")) { |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
1780
|
|
|
|
|
|
HV *hv; |
1781
|
|
|
|
|
|
I32 i; |
1782
|
16146
|
100
|
|
|
|
if (!PL_psig_name) { |
1783
|
16108
|
|
|
|
|
Newxz(PL_psig_name, 2 * SIG_SIZE, SV*); |
1784
|
16108
|
|
|
|
|
Newxz(PL_psig_pend, SIG_SIZE, int); |
1785
|
16108
|
|
|
|
|
PL_psig_ptr = PL_psig_name + SIG_SIZE; |
1786
|
|
|
|
|
|
} else { |
1787
|
|
|
|
|
|
/* I think that the only way to get here is to re-use an |
1788
|
|
|
|
|
|
embedded perl interpreter, where the previous |
1789
|
|
|
|
|
|
use didn't clean up fully because |
1790
|
|
|
|
|
|
PL_perl_destruct_level was 0. I'm not sure that we |
1791
|
|
|
|
|
|
"support" that, in that I suspect in that scenario |
1792
|
|
|
|
|
|
there are sufficient other garbage values left in the |
1793
|
|
|
|
|
|
interpreter structure that something else will crash |
1794
|
|
|
|
|
|
before we get here. I suspect that this is one of |
1795
|
|
|
|
|
|
those "doctor, it hurts when I do this" bugs. */ |
1796
|
38
|
|
|
|
|
Zero(PL_psig_name, 2 * SIG_SIZE, SV*); |
1797
|
38
|
|
|
|
|
Zero(PL_psig_pend, SIG_SIZE, int); |
1798
|
|
|
|
|
|
} |
1799
|
16146
|
|
|
|
|
GvMULTI_on(gv); |
1800
|
16146
|
50
|
|
|
|
hv = GvHVn(gv); |
1801
|
16146
|
|
|
|
|
hv_magic(hv, NULL, PERL_MAGIC_sig); |
1802
|
1114074
|
100
|
|
|
|
for (i = 1; i < SIG_SIZE; i++) { |
1803
|
1097928
|
|
|
|
|
SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); |
1804
|
1097928
|
50
|
|
|
|
if (init) |
1805
|
1097928
|
|
|
|
|
sv_setsv(*init, &PL_sv_undef); |
1806
|
|
|
|
|
|
} |
1807
|
|
|
|
|
|
} |
1808
|
|
|
|
|
|
break; |
1809
|
|
|
|
|
|
case 'V': |
1810
|
1642
|
100
|
|
|
|
if (strEQ(name2, "ERSION")) |
1811
|
896
|
|
|
|
|
GvMULTI_on(gv); |
1812
|
|
|
|
|
|
break; |
1813
|
|
|
|
|
|
case '\003': /* $^CHILD_ERROR_NATIVE */ |
1814
|
6
|
50
|
|
|
|
if (strEQ(name2, "HILD_ERROR_NATIVE")) |
1815
|
|
|
|
|
|
goto magicalize; |
1816
|
|
|
|
|
|
break; |
1817
|
|
|
|
|
|
case '\005': /* $^ENCODING */ |
1818
|
248
|
50
|
|
|
|
if (strEQ(name2, "NCODING")) |
1819
|
|
|
|
|
|
goto magicalize; |
1820
|
|
|
|
|
|
break; |
1821
|
|
|
|
|
|
case '\007': /* $^GLOBAL_PHASE */ |
1822
|
4
|
50
|
|
|
|
if (strEQ(name2, "LOBAL_PHASE")) |
1823
|
|
|
|
|
|
goto ro_magicalize; |
1824
|
|
|
|
|
|
break; |
1825
|
|
|
|
|
|
case '\014': /* $^LAST_FH */ |
1826
|
2
|
50
|
|
|
|
if (strEQ(name2, "AST_FH")) |
1827
|
|
|
|
|
|
goto ro_magicalize; |
1828
|
|
|
|
|
|
break; |
1829
|
|
|
|
|
|
case '\015': /* $^MATCH */ |
1830
|
6
|
100
|
|
|
|
if (strEQ(name2, "ATCH")) |
1831
|
|
|
|
|
|
goto magicalize; |
1832
|
|
|
|
|
|
break; |
1833
|
|
|
|
|
|
case '\017': /* $^OPEN */ |
1834
|
404
|
50
|
|
|
|
if (strEQ(name2, "PEN")) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1835
|
|
|
|
|
|
goto magicalize; |
1836
|
|
|
|
|
|
break; |
1837
|
|
|
|
|
|
case '\020': /* $^PREMATCH $^POSTMATCH */ |
1838
|
202
|
100
|
|
|
|
if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH")) |
|
|
50
|
|
|
|
|
1839
|
|
|
|
|
|
goto magicalize; |
1840
|
|
|
|
|
|
break; |
1841
|
|
|
|
|
|
case '\024': /* ${^TAINT} */ |
1842
|
9876
|
50
|
|
|
|
if (strEQ(name2, "AINT")) |
1843
|
|
|
|
|
|
goto ro_magicalize; |
1844
|
|
|
|
|
|
break; |
1845
|
|
|
|
|
|
case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */ |
1846
|
754
|
100
|
|
|
|
if (strEQ(name2, "NICODE")) |
1847
|
|
|
|
|
|
goto ro_magicalize; |
1848
|
274
|
100
|
|
|
|
if (strEQ(name2, "TF8LOCALE")) |
1849
|
|
|
|
|
|
goto ro_magicalize; |
1850
|
16
|
50
|
|
|
|
if (strEQ(name2, "TF8CACHE")) |
1851
|
|
|
|
|
|
goto magicalize; |
1852
|
|
|
|
|
|
break; |
1853
|
|
|
|
|
|
case '\027': /* $^WARNING_BITS */ |
1854
|
18494
|
50
|
|
|
|
if (strEQ(name2, "ARNING_BITS")) |
1855
|
|
|
|
|
|
goto magicalize; |
1856
|
|
|
|
|
|
break; |
1857
|
|
|
|
|
|
case '1': |
1858
|
|
|
|
|
|
case '2': |
1859
|
|
|
|
|
|
case '3': |
1860
|
|
|
|
|
|
case '4': |
1861
|
|
|
|
|
|
case '5': |
1862
|
|
|
|
|
|
case '6': |
1863
|
|
|
|
|
|
case '7': |
1864
|
|
|
|
|
|
case '8': |
1865
|
|
|
|
|
|
case '9': |
1866
|
|
|
|
|
|
{ |
1867
|
|
|
|
|
|
/* Ensures that we have an all-digit variable, ${"1foo"} fails |
1868
|
|
|
|
|
|
this test */ |
1869
|
|
|
|
|
|
/* This snippet is taken from is_gv_magical */ |
1870
|
60
|
|
|
|
|
const char *end = name + len; |
1871
|
168
|
100
|
|
|
|
while (--end > name) { |
1872
|
88
|
100
|
|
|
|
if (!isDIGIT(*end)) goto add_magical_gv; |
1873
|
|
|
|
|
|
} |
1874
|
|
|
|
|
|
goto magicalize; |
1875
|
|
|
|
|
|
} |
1876
|
|
|
|
|
|
} |
1877
|
|
|
|
|
|
} |
1878
|
|
|
|
|
|
} else { |
1879
|
|
|
|
|
|
/* Names of length 1. (Or 0. But name is NUL terminated, so that will |
1880
|
|
|
|
|
|
be case '\0' in this switch statement (ie a default case) */ |
1881
|
491570
|
|
|
|
|
switch (*name) { |
1882
|
|
|
|
|
|
case '&': /* $& */ |
1883
|
|
|
|
|
|
case '`': /* $` */ |
1884
|
|
|
|
|
|
case '\'': /* $' */ |
1885
|
|
|
|
|
|
#ifdef PERL_SAWAMPERSAND |
1886
|
|
|
|
|
|
if (!( |
1887
|
|
|
|
|
|
sv_type == SVt_PVAV || |
1888
|
|
|
|
|
|
sv_type == SVt_PVHV || |
1889
|
|
|
|
|
|
sv_type == SVt_PVCV || |
1890
|
|
|
|
|
|
sv_type == SVt_PVFM || |
1891
|
|
|
|
|
|
sv_type == SVt_PVIO |
1892
|
|
|
|
|
|
)) { PL_sawampersand |= |
1893
|
|
|
|
|
|
(*name == '`') |
1894
|
|
|
|
|
|
? SAWAMPERSAND_LEFT |
1895
|
|
|
|
|
|
: (*name == '&') |
1896
|
|
|
|
|
|
? SAWAMPERSAND_MIDDLE |
1897
|
|
|
|
|
|
: SAWAMPERSAND_RIGHT; |
1898
|
|
|
|
|
|
} |
1899
|
|
|
|
|
|
#endif |
1900
|
|
|
|
|
|
goto magicalize; |
1901
|
|
|
|
|
|
|
1902
|
|
|
|
|
|
case ':': /* $: */ |
1903
|
1504
|
50
|
|
|
|
sv_setpv(GvSVn(gv),PL_chopset); |
1904
|
1504
|
|
|
|
|
goto magicalize; |
1905
|
|
|
|
|
|
|
1906
|
|
|
|
|
|
case '?': /* $? */ |
1907
|
|
|
|
|
|
#ifdef COMPLEX_STATUS |
1908
|
|
|
|
|
|
SvUPGRADE(GvSVn(gv), SVt_PVLV); |
1909
|
|
|
|
|
|
#endif |
1910
|
|
|
|
|
|
goto magicalize; |
1911
|
|
|
|
|
|
|
1912
|
|
|
|
|
|
case '!': /* $! */ |
1913
|
18486
|
|
|
|
|
GvMULTI_on(gv); |
1914
|
|
|
|
|
|
/* If %! has been used, automatically load Errno.pm. */ |
1915
|
|
|
|
|
|
|
1916
|
18486
|
50
|
|
|
|
sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); |
1917
|
|
|
|
|
|
|
1918
|
|
|
|
|
|
/* magicalization must be done before require_tie_mod is called */ |
1919
|
18486
|
50
|
|
|
|
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) |
1920
|
|
|
|
|
|
{ |
1921
|
0
|
0
|
|
|
|
if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0); |
1922
|
|
|
|
|
|
addmg = 0; |
1923
|
0
|
|
|
|
|
require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); |
1924
|
|
|
|
|
|
} |
1925
|
|
|
|
|
|
|
1926
|
|
|
|
|
|
break; |
1927
|
|
|
|
|
|
case '-': /* $- */ |
1928
|
|
|
|
|
|
case '+': /* $+ */ |
1929
|
3794
|
|
|
|
|
GvMULTI_on(gv); /* no used once warnings here */ |
1930
|
|
|
|
|
|
{ |
1931
|
3794
|
50
|
|
|
|
AV* const av = GvAVn(gv); |
1932
|
3794
|
100
|
|
|
|
SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL; |
1933
|
|
|
|
|
|
|
1934
|
3794
|
|
|
|
|
sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0); |
1935
|
3794
|
50
|
|
|
|
sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); |
1936
|
3794
|
100
|
|
|
|
if (avc) |
1937
|
1896
|
50
|
|
|
|
SvREADONLY_on(GvSVn(gv)); |
1938
|
3794
|
|
|
|
|
SvREADONLY_on(av); |
1939
|
|
|
|
|
|
|
1940
|
3794
|
100
|
|
|
|
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) |
1941
|
|
|
|
|
|
{ |
1942
|
808
|
100
|
|
|
|
if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0); |
1943
|
|
|
|
|
|
addmg = 0; |
1944
|
808
|
|
|
|
|
require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); |
1945
|
|
|
|
|
|
} |
1946
|
|
|
|
|
|
|
1947
|
|
|
|
|
|
break; |
1948
|
|
|
|
|
|
} |
1949
|
|
|
|
|
|
case '*': /* $* */ |
1950
|
|
|
|
|
|
case '#': /* $# */ |
1951
|
32
|
100
|
|
|
|
if (sv_type == SVt_PV) |
1952
|
|
|
|
|
|
/* diag_listed_as: $* is no longer supported */ |
1953
|
26
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), |
1954
|
26
|
|
|
|
|
"$%c is no longer supported", *name); |
1955
|
|
|
|
|
|
break; |
1956
|
|
|
|
|
|
case '\010': /* $^H */ |
1957
|
|
|
|
|
|
{ |
1958
|
24346
|
50
|
|
|
|
HV *const hv = GvHVn(gv); |
1959
|
24346
|
|
|
|
|
hv_magic(hv, NULL, PERL_MAGIC_hints); |
1960
|
|
|
|
|
|
} |
1961
|
24346
|
|
|
|
|
goto magicalize; |
1962
|
|
|
|
|
|
case '[': /* $[ */ |
1963
|
362
|
50
|
|
|
|
if ((sv_type == SVt_PV || sv_type == SVt_PVGV) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1964
|
361
|
100
|
|
|
|
&& FEATURE_ARYBASE_IS_ENABLED) { |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1965
|
232
|
100
|
|
|
|
if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0); |
1966
|
232
|
|
|
|
|
require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0); |
1967
|
|
|
|
|
|
addmg = 0; |
1968
|
|
|
|
|
|
} |
1969
|
|
|
|
|
|
else goto magicalize; |
1970
|
232
|
|
|
|
|
break; |
1971
|
|
|
|
|
|
case '\023': /* $^S */ |
1972
|
|
|
|
|
|
ro_magicalize: |
1973
|
10826
|
50
|
|
|
|
SvREADONLY_on(GvSVn(gv)); |
1974
|
|
|
|
|
|
/* FALL THROUGH */ |
1975
|
|
|
|
|
|
case '0': /* $0 */ |
1976
|
|
|
|
|
|
case '1': /* $1 */ |
1977
|
|
|
|
|
|
case '2': /* $2 */ |
1978
|
|
|
|
|
|
case '3': /* $3 */ |
1979
|
|
|
|
|
|
case '4': /* $4 */ |
1980
|
|
|
|
|
|
case '5': /* $5 */ |
1981
|
|
|
|
|
|
case '6': /* $6 */ |
1982
|
|
|
|
|
|
case '7': /* $7 */ |
1983
|
|
|
|
|
|
case '8': /* $8 */ |
1984
|
|
|
|
|
|
case '9': /* $9 */ |
1985
|
|
|
|
|
|
case '^': /* $^ */ |
1986
|
|
|
|
|
|
case '~': /* $~ */ |
1987
|
|
|
|
|
|
case '=': /* $= */ |
1988
|
|
|
|
|
|
case '%': /* $% */ |
1989
|
|
|
|
|
|
case '.': /* $. */ |
1990
|
|
|
|
|
|
case '(': /* $( */ |
1991
|
|
|
|
|
|
case ')': /* $) */ |
1992
|
|
|
|
|
|
case '<': /* $< */ |
1993
|
|
|
|
|
|
case '>': /* $> */ |
1994
|
|
|
|
|
|
case '\\': /* $\ */ |
1995
|
|
|
|
|
|
case '/': /* $/ */ |
1996
|
|
|
|
|
|
case '|': /* $| */ |
1997
|
|
|
|
|
|
case '$': /* $$ */ |
1998
|
|
|
|
|
|
case '\001': /* $^A */ |
1999
|
|
|
|
|
|
case '\003': /* $^C */ |
2000
|
|
|
|
|
|
case '\004': /* $^D */ |
2001
|
|
|
|
|
|
case '\005': /* $^E */ |
2002
|
|
|
|
|
|
case '\006': /* $^F */ |
2003
|
|
|
|
|
|
case '\011': /* $^I, NOT \t in EBCDIC */ |
2004
|
|
|
|
|
|
case '\016': /* $^N */ |
2005
|
|
|
|
|
|
case '\017': /* $^O */ |
2006
|
|
|
|
|
|
case '\020': /* $^P */ |
2007
|
|
|
|
|
|
case '\024': /* $^T */ |
2008
|
|
|
|
|
|
case '\027': /* $^W */ |
2009
|
|
|
|
|
|
magicalize: |
2010
|
286278
|
100
|
|
|
|
sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); |
2011
|
286278
|
|
|
|
|
break; |
2012
|
|
|
|
|
|
|
2013
|
|
|
|
|
|
case '\014': /* $^L */ |
2014
|
1498
|
50
|
|
|
|
sv_setpvs(GvSVn(gv),"\f"); |
2015
|
1498
|
|
|
|
|
break; |
2016
|
|
|
|
|
|
case ';': /* $; */ |
2017
|
2602
|
50
|
|
|
|
sv_setpvs(GvSVn(gv),"\034"); |
2018
|
2602
|
|
|
|
|
break; |
2019
|
|
|
|
|
|
case ']': /* $] */ |
2020
|
|
|
|
|
|
{ |
2021
|
16736
|
|
|
|
|
SV * const sv = GvSV(gv); |
2022
|
16736
|
100
|
|
|
|
if (!sv_derived_from(PL_patchlevel, "version")) |
2023
|
474
|
|
|
|
|
upg_version(PL_patchlevel, TRUE); |
2024
|
16736
|
|
|
|
|
GvSV(gv) = vnumify(PL_patchlevel); |
2025
|
16736
|
|
|
|
|
SvREADONLY_on(GvSV(gv)); |
2026
|
16736
|
|
|
|
|
SvREFCNT_dec(sv); |
2027
|
|
|
|
|
|
} |
2028
|
16736
|
|
|
|
|
break; |
2029
|
|
|
|
|
|
case '\026': /* $^V */ |
2030
|
|
|
|
|
|
{ |
2031
|
11864
|
|
|
|
|
SV * const sv = GvSV(gv); |
2032
|
11864
|
|
|
|
|
GvSV(gv) = new_version(PL_patchlevel); |
2033
|
11864
|
|
|
|
|
SvREADONLY_on(GvSV(gv)); |
2034
|
11864
|
|
|
|
|
SvREFCNT_dec(sv); |
2035
|
|
|
|
|
|
} |
2036
|
11864
|
|
|
|
|
break; |
2037
|
|
|
|
|
|
} |
2038
|
|
|
|
|
|
} |
2039
|
|
|
|
|
|
add_magical_gv: |
2040
|
25559014
|
100
|
|
|
|
if (addmg) { |
2041
|
528178
|
100
|
|
|
|
if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || ( |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2042
|
174480
|
100
|
|
|
|
GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv))) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2043
|
|
|
|
|
|
)) |
2044
|
1060
|
|
|
|
|
(void)hv_store(stash,name,len,(SV *)gv,0); |
2045
|
352708
|
|
|
|
|
else SvREFCNT_dec_NN(gv), gv = NULL; |
2046
|
|
|
|
|
|
} |
2047
|
515439947
|
100
|
|
|
|
if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type); |
|
|
100
|
|
|
|
|
2048
|
|
|
|
|
|
return gv; |
2049
|
|
|
|
|
|
} |
2050
|
|
|
|
|
|
|
2051
|
|
|
|
|
|
void |
2052
|
5136007
|
|
|
|
|
Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) |
2053
|
|
|
|
|
|
{ |
2054
|
|
|
|
|
|
const char *name; |
2055
|
5136007
|
|
|
|
|
const HV * const hv = GvSTASH(gv); |
2056
|
|
|
|
|
|
|
2057
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_FULLNAME4; |
2058
|
|
|
|
|
|
|
2059
|
5136007
|
100
|
|
|
|
sv_setpv(sv, prefix ? prefix : ""); |
2060
|
|
|
|
|
|
|
2061
|
5136007
|
100
|
|
|
|
if (hv && (name = HvNAME(hv))) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2062
|
5135983
|
50
|
|
|
|
const STRLEN len = HvNAMELEN(hv); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2063
|
5135983
|
100
|
|
|
|
if (keepmain || strnNE(name, "main", len)) { |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
2064
|
5135049
|
50
|
|
|
|
sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2065
|
5135049
|
|
|
|
|
sv_catpvs(sv,"::"); |
2066
|
|
|
|
|
|
} |
2067
|
|
|
|
|
|
} |
2068
|
24
|
|
|
|
|
else sv_catpvs(sv,"__ANON__::"); |
2069
|
5136007
|
|
|
|
|
sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv)))); |
2070
|
5136007
|
|
|
|
|
} |
2071
|
|
|
|
|
|
|
2072
|
|
|
|
|
|
void |
2073
|
5135097
|
|
|
|
|
Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) |
2074
|
|
|
|
|
|
{ |
2075
|
5135097
|
50
|
|
|
|
const GV * const egv = GvEGVx(gv); |
|
|
50
|
|
|
|
|
2076
|
|
|
|
|
|
|
2077
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_EFULLNAME4; |
2078
|
|
|
|
|
|
|
2079
|
5135097
|
100
|
|
|
|
gv_fullname4(sv, egv ? egv : gv, prefix, keepmain); |
2080
|
5135097
|
|
|
|
|
} |
2081
|
|
|
|
|
|
|
2082
|
|
|
|
|
|
void |
2083
|
1329382
|
|
|
|
|
Perl_gv_check(pTHX_ HV *stash) |
2084
|
|
|
|
|
|
{ |
2085
|
|
|
|
|
|
dVAR; |
2086
|
|
|
|
|
|
I32 i; |
2087
|
|
|
|
|
|
|
2088
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_CHECK; |
2089
|
|
|
|
|
|
|
2090
|
1329382
|
50
|
|
|
|
if (!HvARRAY(stash)) |
2091
|
1329382
|
|
|
|
|
return; |
2092
|
35271467
|
100
|
|
|
|
for (i = 0; i <= (I32) HvMAX(stash); i++) { |
2093
|
|
|
|
|
|
const HE *entry; |
2094
|
|
|
|
|
|
/* SvIsCOW is unused on HVs, so we can use it to mark stashes we |
2095
|
|
|
|
|
|
are currently searching through recursively. */ |
2096
|
34578336
|
|
|
|
|
SvIsCOW_on(stash); |
2097
|
54796406
|
100
|
|
|
|
for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { |
2098
|
|
|
|
|
|
GV *gv; |
2099
|
|
|
|
|
|
HV *hv; |
2100
|
20855003
|
100
|
|
|
|
if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && |
|
|
50
|
|
|
|
|
2101
|
1967679
|
100
|
|
|
|
(gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv))) |
|
|
100
|
|
|
|
|
2102
|
|
|
|
|
|
{ |
2103
|
1329384
|
100
|
|
|
|
if (hv != PL_defstash && hv != stash && !SvIsCOW(hv)) |
|
|
100
|
|
|
|
|
2104
|
1311512
|
|
|
|
|
gv_check(hv); /* nested package */ |
2105
|
|
|
|
|
|
} |
2106
|
18888686
|
100
|
|
|
|
else if ( *HeKEY(entry) != '_' |
2107
|
17012686
|
50
|
|
|
|
&& isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) { |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
2108
|
|
|
|
|
|
const char *file; |
2109
|
16291988
|
|
|
|
|
gv = MUTABLE_GV(HeVAL(entry)); |
2110
|
16291988
|
100
|
|
|
|
if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) |
|
|
100
|
|
|
|
|
2111
|
16291868
|
|
|
|
|
continue; |
2112
|
120
|
50
|
|
|
|
file = GvFILE(gv); |
2113
|
120
|
|
|
|
|
CopLINE_set(PL_curcop, GvLINE(gv)); |
2114
|
|
|
|
|
|
#ifdef USE_ITHREADS |
2115
|
|
|
|
|
|
CopFILE(PL_curcop) = (char *)file; /* set for warning */ |
2116
|
|
|
|
|
|
#else |
2117
|
120
|
|
|
|
|
CopFILEGV(PL_curcop) |
2118
|
120
|
|
|
|
|
= gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0); |
2119
|
|
|
|
|
|
#endif |
2120
|
300
|
50
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_ONCE), |
|
|
50
|
|
|
|
|
2121
|
|
|
|
|
|
"Name \"%"HEKf"::%"HEKf |
2122
|
|
|
|
|
|
"\" used only once: possible typo", |
2123
|
240
|
50
|
|
|
|
HEKfARG(HvNAME_HEK(stash)), |
2124
|
120
|
|
|
|
|
HEKfARG(GvNAME_HEK(gv))); |
2125
|
|
|
|
|
|
} |
2126
|
|
|
|
|
|
} |
2127
|
34578336
|
|
|
|
|
SvIsCOW_off(stash); |
2128
|
|
|
|
|
|
} |
2129
|
|
|
|
|
|
} |
2130
|
|
|
|
|
|
|
2131
|
|
|
|
|
|
GV * |
2132
|
394
|
|
|
|
|
Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags) |
2133
|
|
|
|
|
|
{ |
2134
|
|
|
|
|
|
dVAR; |
2135
|
|
|
|
|
|
PERL_ARGS_ASSERT_NEWGVGEN_FLAGS; |
2136
|
|
|
|
|
|
assert(!(flags & ~SVf_UTF8)); |
2137
|
|
|
|
|
|
|
2138
|
394
|
|
|
|
|
return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld", |
2139
|
|
|
|
|
|
UTF8fARG(flags, strlen(pack), pack), |
2140
|
|
|
|
|
|
(long)PL_gensym++), |
2141
|
|
|
|
|
|
GV_ADD, SVt_PVGV); |
2142
|
|
|
|
|
|
} |
2143
|
|
|
|
|
|
|
2144
|
|
|
|
|
|
/* hopefully this is only called on local symbol table entries */ |
2145
|
|
|
|
|
|
|
2146
|
|
|
|
|
|
GP* |
2147
|
44425602
|
|
|
|
|
Perl_gp_ref(pTHX_ GP *gp) |
2148
|
|
|
|
|
|
{ |
2149
|
|
|
|
|
|
dVAR; |
2150
|
44425602
|
50
|
|
|
|
if (!gp) |
2151
|
|
|
|
|
|
return NULL; |
2152
|
44425602
|
|
|
|
|
gp->gp_refcnt++; |
2153
|
44425602
|
100
|
|
|
|
if (gp->gp_cv) { |
2154
|
19907184
|
100
|
|
|
|
if (gp->gp_cvgen) { |
2155
|
|
|
|
|
|
/* If the GP they asked for a reference to contains |
2156
|
|
|
|
|
|
a method cache entry, clear it first, so that we |
2157
|
|
|
|
|
|
don't infect them with our cached entry */ |
2158
|
10
|
|
|
|
|
SvREFCNT_dec_NN(gp->gp_cv); |
2159
|
10
|
|
|
|
|
gp->gp_cv = NULL; |
2160
|
22219551
|
|
|
|
|
gp->gp_cvgen = 0; |
2161
|
|
|
|
|
|
} |
2162
|
|
|
|
|
|
} |
2163
|
|
|
|
|
|
return gp; |
2164
|
|
|
|
|
|
} |
2165
|
|
|
|
|
|
|
2166
|
|
|
|
|
|
void |
2167
|
82319239
|
|
|
|
|
Perl_gp_free(pTHX_ GV *gv) |
2168
|
|
|
|
|
|
{ |
2169
|
|
|
|
|
|
dVAR; |
2170
|
|
|
|
|
|
GP* gp; |
2171
|
|
|
|
|
|
int attempts = 100; |
2172
|
|
|
|
|
|
|
2173
|
82319239
|
50
|
|
|
|
if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv))) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2174
|
|
|
|
|
|
return; |
2175
|
54907563
|
50
|
|
|
|
if (gp->gp_refcnt == 0) { |
2176
|
0
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), |
2177
|
|
|
|
|
|
"Attempt to free unreferenced glob pointers" |
2178
|
|
|
|
|
|
pTHX__FORMAT pTHX__VALUE); |
2179
|
0
|
|
|
|
|
return; |
2180
|
|
|
|
|
|
} |
2181
|
54907563
|
100
|
|
|
|
if (--gp->gp_refcnt > 0) { |
2182
|
44346778
|
100
|
|
|
|
if (gp->gp_egv == gv) |
2183
|
345337
|
|
|
|
|
gp->gp_egv = 0; |
2184
|
44346778
|
|
|
|
|
GvGP_set(gv, NULL); |
2185
|
44346779
|
|
|
|
|
return; |
2186
|
|
|
|
|
|
} |
2187
|
|
|
|
|
|
|
2188
|
|
|
|
|
|
while (1) { |
2189
|
|
|
|
|
|
/* Copy and null out all the glob slots, so destructors do not see |
2190
|
|
|
|
|
|
freed SVs. */ |
2191
|
10560787
|
|
|
|
|
HEK * const file_hek = gp->gp_file_hek; |
2192
|
10560787
|
|
|
|
|
SV * const sv = gp->gp_sv; |
2193
|
10560787
|
|
|
|
|
AV * const av = gp->gp_av; |
2194
|
10560787
|
|
|
|
|
HV * const hv = gp->gp_hv; |
2195
|
10560787
|
|
|
|
|
IO * const io = gp->gp_io; |
2196
|
10560787
|
|
|
|
|
CV * const cv = gp->gp_cv; |
2197
|
10560787
|
|
|
|
|
CV * const form = gp->gp_form; |
2198
|
|
|
|
|
|
|
2199
|
10560787
|
|
|
|
|
gp->gp_file_hek = NULL; |
2200
|
10560787
|
|
|
|
|
gp->gp_sv = NULL; |
2201
|
10560787
|
|
|
|
|
gp->gp_av = NULL; |
2202
|
10560787
|
|
|
|
|
gp->gp_hv = NULL; |
2203
|
10560787
|
|
|
|
|
gp->gp_io = NULL; |
2204
|
10560787
|
|
|
|
|
gp->gp_cv = NULL; |
2205
|
10560787
|
|
|
|
|
gp->gp_form = NULL; |
2206
|
|
|
|
|
|
|
2207
|
10560787
|
100
|
|
|
|
if (file_hek) |
2208
|
10560163
|
|
|
|
|
unshare_hek(file_hek); |
2209
|
|
|
|
|
|
|
2210
|
10560787
|
|
|
|
|
SvREFCNT_dec(sv); |
2211
|
10560787
|
|
|
|
|
SvREFCNT_dec(av); |
2212
|
|
|
|
|
|
/* FIXME - another reference loop GV -> symtab -> GV ? |
2213
|
|
|
|
|
|
Somehow gp->gp_hv can end up pointing at freed garbage. */ |
2214
|
10560787
|
100
|
|
|
|
if (hv && SvTYPE(hv) == SVt_PVHV) { |
|
|
50
|
|
|
|
|
2215
|
31684
|
100
|
|
|
|
const HEK *hvname_hek = HvNAME_HEK(hv); |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2216
|
|
|
|
|
|
DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", hvname_hek)); |
2217
|
31684
|
100
|
|
|
|
if (PL_stashcache && hvname_hek) |
2218
|
778
|
100
|
|
|
|
(void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek), |
2219
|
|
|
|
|
|
(HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) : HEK_LEN(hvname_hek)), |
2220
|
|
|
|
|
|
G_DISCARD); |
2221
|
31684
|
|
|
|
|
SvREFCNT_dec(hv); |
2222
|
|
|
|
|
|
} |
2223
|
10560787
|
|
|
|
|
SvREFCNT_dec(io); |
2224
|
10560785
|
|
|
|
|
SvREFCNT_dec(cv); |
2225
|
10560783
|
|
|
|
|
SvREFCNT_dec(form); |
2226
|
|
|
|
|
|
|
2227
|
10560783
|
50
|
|
|
|
if (!gp->gp_file_hek |
2228
|
10560783
|
100
|
|
|
|
&& !gp->gp_sv |
2229
|
10560781
|
50
|
|
|
|
&& !gp->gp_av |
2230
|
10560781
|
50
|
|
|
|
&& !gp->gp_hv |
2231
|
10560781
|
50
|
|
|
|
&& !gp->gp_io |
2232
|
10560781
|
50
|
|
|
|
&& !gp->gp_cv |
2233
|
10560781
|
50
|
|
|
|
&& !gp->gp_form) break; |
2234
|
|
|
|
|
|
|
2235
|
2
|
50
|
|
|
|
if (--attempts == 0) { |
2236
|
0
|
|
|
|
|
Perl_die(aTHX_ |
2237
|
|
|
|
|
|
"panic: gp_free failed to free glob pointer - " |
2238
|
|
|
|
|
|
"something is repeatedly re-creating entries" |
2239
|
|
|
|
|
|
); |
2240
|
|
|
|
|
|
} |
2241
|
|
|
|
|
|
} |
2242
|
|
|
|
|
|
|
2243
|
10560781
|
|
|
|
|
Safefree(gp); |
2244
|
46445674
|
|
|
|
|
GvGP_set(gv, NULL); |
2245
|
|
|
|
|
|
} |
2246
|
|
|
|
|
|
|
2247
|
|
|
|
|
|
int |
2248
|
364156
|
|
|
|
|
Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) |
2249
|
|
|
|
|
|
{ |
2250
|
364156
|
|
|
|
|
AMT * const amtp = (AMT*)mg->mg_ptr; |
2251
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
2252
|
|
|
|
|
|
|
2253
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_FREEOVRLD; |
2254
|
|
|
|
|
|
|
2255
|
364156
|
50
|
|
|
|
if (amtp && AMT_AMAGIC(amtp)) { |
|
|
100
|
|
|
|
|
2256
|
|
|
|
|
|
int i; |
2257
|
523125
|
100
|
|
|
|
for (i = 1; i < NofAMmeth; i++) { |
2258
|
519250
|
|
|
|
|
CV * const cv = amtp->table[i]; |
2259
|
519250
|
100
|
|
|
|
if (cv) { |
2260
|
122132
|
|
|
|
|
SvREFCNT_dec_NN(MUTABLE_SV(cv)); |
2261
|
122132
|
|
|
|
|
amtp->table[i] = NULL; |
2262
|
|
|
|
|
|
} |
2263
|
|
|
|
|
|
} |
2264
|
|
|
|
|
|
} |
2265
|
364156
|
|
|
|
|
return 0; |
2266
|
|
|
|
|
|
} |
2267
|
|
|
|
|
|
|
2268
|
|
|
|
|
|
/* Updates and caches the CV's */ |
2269
|
|
|
|
|
|
/* Returns: |
2270
|
|
|
|
|
|
* 1 on success and there is some overload |
2271
|
|
|
|
|
|
* 0 if there is no overload |
2272
|
|
|
|
|
|
* -1 if some error occurred and it couldn't croak |
2273
|
|
|
|
|
|
*/ |
2274
|
|
|
|
|
|
|
2275
|
|
|
|
|
|
int |
2276
|
5459893
|
|
|
|
|
Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) |
2277
|
|
|
|
|
|
{ |
2278
|
|
|
|
|
|
dVAR; |
2279
|
5459893
|
|
|
|
|
MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); |
2280
|
|
|
|
|
|
AMT amt; |
2281
|
5459893
|
100
|
|
|
|
const struct mro_meta* stash_meta = HvMROMETA(stash); |
2282
|
|
|
|
|
|
U32 newgen; |
2283
|
|
|
|
|
|
|
2284
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_AMUPDATE; |
2285
|
|
|
|
|
|
|
2286
|
5459893
|
|
|
|
|
newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; |
2287
|
5459893
|
100
|
|
|
|
if (mg) { |
2288
|
5296844
|
|
|
|
|
const AMT * const amtp = (AMT*)mg->mg_ptr; |
2289
|
5296844
|
100
|
|
|
|
if (amtp->was_ok_sub == newgen) { |
2290
|
4932706
|
|
|
|
|
return AMT_AMAGIC(amtp) ? 1 : 0; |
2291
|
|
|
|
|
|
} |
2292
|
364138
|
|
|
|
|
sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table); |
2293
|
|
|
|
|
|
} |
2294
|
|
|
|
|
|
|
2295
|
|
|
|
|
|
DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) ); |
2296
|
|
|
|
|
|
|
2297
|
|
|
|
|
|
Zero(&amt,1,AMT); |
2298
|
527187
|
|
|
|
|
amt.was_ok_sub = newgen; |
2299
|
527187
|
|
|
|
|
amt.fallback = AMGfallNO; |
2300
|
527187
|
|
|
|
|
amt.flags = 0; |
2301
|
|
|
|
|
|
|
2302
|
|
|
|
|
|
{ |
2303
|
|
|
|
|
|
int filled = 0; |
2304
|
|
|
|
|
|
int i; |
2305
|
|
|
|
|
|
|
2306
|
|
|
|
|
|
/* Work with "fallback" key, which we assume to be first in PL_AMG_names */ |
2307
|
|
|
|
|
|
|
2308
|
|
|
|
|
|
/* Try to find via inheritance. */ |
2309
|
527187
|
|
|
|
|
GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0); |
2310
|
527187
|
100
|
|
|
|
SV * const sv = gv ? GvSV(gv) : NULL; |
2311
|
|
|
|
|
|
CV* cv; |
2312
|
|
|
|
|
|
|
2313
|
527187
|
100
|
|
|
|
if (!gv) |
2314
|
|
|
|
|
|
{ |
2315
|
507379
|
100
|
|
|
|
if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0)) |
2316
|
|
|
|
|
|
goto no_table; |
2317
|
|
|
|
|
|
} |
2318
|
|
|
|
|
|
#ifdef PERL_DONT_CREATE_GVSV |
2319
|
19808
|
100
|
|
|
|
else if (!sv) { |
2320
|
|
|
|
|
|
NOOP; /* Equivalent to !SvTRUE and !SvOK */ |
2321
|
|
|
|
|
|
} |
2322
|
|
|
|
|
|
#endif |
2323
|
402
|
50
|
|
|
|
else if (SvTRUE(sv)) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
2324
|
|
|
|
|
|
/* don't need to set overloading here because fallback => 1 |
2325
|
|
|
|
|
|
* is the default setting for classes without overloading */ |
2326
|
10649
|
|
|
|
|
amt.fallback=AMGfallYES; |
2327
|
24
|
100
|
|
|
|
else if (SvOK(sv)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2328
|
8
|
|
|
|
|
amt.fallback=AMGfallNEVER; |
2329
|
8
|
|
|
|
|
filled = 1; |
2330
|
|
|
|
|
|
} |
2331
|
|
|
|
|
|
else { |
2332
|
|
|
|
|
|
filled = 1; |
2333
|
|
|
|
|
|
} |
2334
|
|
|
|
|
|
|
2335
|
1387980
|
100
|
|
|
|
for (i = 1; i < NofAMmeth; i++) { |
2336
|
1377520
|
|
|
|
|
const char * const cooky = PL_AMG_names[i]; |
2337
|
|
|
|
|
|
/* Human-readable form, for debugging: */ |
2338
|
1377520
|
|
|
|
|
const char * const cp = AMG_id2name(i); |
2339
|
1377520
|
|
|
|
|
const STRLEN l = PL_AMG_namelens[i]; |
2340
|
|
|
|
|
|
|
2341
|
|
|
|
|
|
DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n", |
2342
|
|
|
|
|
|
cp, HvNAME_get(stash)) ); |
2343
|
|
|
|
|
|
/* don't fill the cache while looking up! |
2344
|
|
|
|
|
|
Creation of inheritance stubs in intermediate packages may |
2345
|
|
|
|
|
|
conflict with the logic of runtime method substitution. |
2346
|
|
|
|
|
|
Indeed, for inheritance A -> B -> C, if C overloads "+0", |
2347
|
|
|
|
|
|
then we could have created stubs for "(+0" in A and C too. |
2348
|
|
|
|
|
|
But if B overloads "bool", we may want to use it for |
2349
|
|
|
|
|
|
numifying instead of C's "+0". */ |
2350
|
1377520
|
|
|
|
|
gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0); |
2351
|
|
|
|
|
|
cv = 0; |
2352
|
1377520
|
100
|
|
|
|
if (gv && (cv = GvCV(gv))) { |
|
|
50
|
|
|
|
|
2353
|
432024
|
100
|
|
|
|
if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){ |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2354
|
3145
|
50
|
|
|
|
const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv))); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2355
|
2405
|
50
|
|
|
|
if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8 |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2356
|
370
|
50
|
|
|
|
&& strEQ(hvname, "overload")) { |
2357
|
|
|
|
|
|
/* This is a hack to support autoloading..., while |
2358
|
|
|
|
|
|
knowing *which* methods were declared as overloaded. */ |
2359
|
|
|
|
|
|
/* GvSV contains the name of the method. */ |
2360
|
|
|
|
|
|
GV *ngv = NULL; |
2361
|
370
|
|
|
|
|
SV *gvsv = GvSV(gv); |
2362
|
|
|
|
|
|
|
2363
|
|
|
|
|
|
DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\ |
2364
|
|
|
|
|
|
"\" for overloaded \"%s\" in package \"%.256s\"\n", |
2365
|
|
|
|
|
|
(void*)GvSV(gv), cp, HvNAME(stash)) ); |
2366
|
370
|
50
|
|
|
|
if (!gvsv || !SvPOK(gvsv) |
|
|
50
|
|
|
|
|
2367
|
370
|
50
|
|
|
|
|| !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0))) |
2368
|
|
|
|
|
|
{ |
2369
|
|
|
|
|
|
/* Can be an import stub (created by "can"). */ |
2370
|
0
|
0
|
|
|
|
if (destructing) { |
2371
|
|
|
|
|
|
return -1; |
2372
|
|
|
|
|
|
} |
2373
|
|
|
|
|
|
else { |
2374
|
0
|
0
|
|
|
|
const SV * const name = (gvsv && SvPOK(gvsv)) |
2375
|
|
|
|
|
|
? gvsv |
2376
|
0
|
0
|
|
|
|
: newSVpvs_flags("???", SVs_TEMP); |
2377
|
|
|
|
|
|
/* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */ |
2378
|
0
|
0
|
|
|
|
Perl_croak(aTHX_ "%s method \"%"SVf256 |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
2379
|
|
|
|
|
|
"\" overloading \"%s\" "\ |
2380
|
|
|
|
|
|
"in package \"%"HEKf256"\"", |
2381
|
0
|
|
|
|
|
(GvCVGEN(gv) ? "Stub found while resolving" |
2382
|
|
|
|
|
|
: "Can't resolve"), |
2383
|
|
|
|
|
|
SVfARG(name), cp, |
2384
|
0
|
0
|
|
|
|
HEKfARG( |
2385
|
|
|
|
|
|
HvNAME_HEK(stash) |
2386
|
|
|
|
|
|
)); |
2387
|
|
|
|
|
|
} |
2388
|
|
|
|
|
|
} |
2389
|
370
|
|
|
|
|
cv = GvCV(gv = ngv); |
2390
|
|
|
|
|
|
} |
2391
|
|
|
|
|
|
} |
2392
|
|
|
|
|
|
DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n", |
2393
|
|
|
|
|
|
cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), |
2394
|
|
|
|
|
|
GvNAME(CvGV(cv))) ); |
2395
|
|
|
|
|
|
filled = 1; |
2396
|
1062346
|
50
|
|
|
|
} else if (gv) { /* Autoloaded... */ |
2397
|
|
|
|
|
|
cv = MUTABLE_CV(gv); |
2398
|
|
|
|
|
|
filled = 1; |
2399
|
|
|
|
|
|
} |
2400
|
1377520
|
|
|
|
|
amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv)); |
2401
|
|
|
|
|
|
} |
2402
|
20560
|
100
|
|
|
|
if (filled) { |
2403
|
20554
|
|
|
|
|
AMT_AMAGIC_on(&amt); |
2404
|
20554
|
|
|
|
|
sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, |
2405
|
|
|
|
|
|
(char*)&amt, sizeof(AMT)); |
2406
|
20554
|
|
|
|
|
return TRUE; |
2407
|
|
|
|
|
|
} |
2408
|
|
|
|
|
|
} |
2409
|
|
|
|
|
|
/* Here we have no table: */ |
2410
|
|
|
|
|
|
no_table: |
2411
|
506633
|
|
|
|
|
AMT_AMAGIC_off(&amt); |
2412
|
506633
|
|
|
|
|
sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, |
2413
|
|
|
|
|
|
(char*)&amt, sizeof(AMTS)); |
2414
|
2983623
|
|
|
|
|
return 0; |
2415
|
|
|
|
|
|
} |
2416
|
|
|
|
|
|
|
2417
|
|
|
|
|
|
|
2418
|
|
|
|
|
|
CV* |
2419
|
0
|
|
|
|
|
Perl_gv_handler(pTHX_ HV *stash, I32 id) |
2420
|
|
|
|
|
|
{ |
2421
|
|
|
|
|
|
dVAR; |
2422
|
|
|
|
|
|
MAGIC *mg; |
2423
|
|
|
|
|
|
AMT *amtp; |
2424
|
|
|
|
|
|
U32 newgen; |
2425
|
|
|
|
|
|
struct mro_meta* stash_meta; |
2426
|
|
|
|
|
|
|
2427
|
0
|
0
|
|
|
|
if (!stash || !HvNAME_get(stash)) |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
2428
|
|
|
|
|
|
return NULL; |
2429
|
|
|
|
|
|
|
2430
|
0
|
0
|
|
|
|
stash_meta = HvMROMETA(stash); |
2431
|
0
|
|
|
|
|
newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; |
2432
|
|
|
|
|
|
|
2433
|
0
|
|
|
|
|
mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); |
2434
|
0
|
0
|
|
|
|
if (!mg) { |
2435
|
|
|
|
|
|
do_update: |
2436
|
0
|
0
|
|
|
|
if (Gv_AMupdate(stash, 0) == -1) |
2437
|
|
|
|
|
|
return NULL; |
2438
|
0
|
|
|
|
|
mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); |
2439
|
|
|
|
|
|
} |
2440
|
|
|
|
|
|
assert(mg); |
2441
|
0
|
|
|
|
|
amtp = (AMT*)mg->mg_ptr; |
2442
|
0
|
0
|
|
|
|
if ( amtp->was_ok_sub != newgen ) |
2443
|
|
|
|
|
|
goto do_update; |
2444
|
0
|
0
|
|
|
|
if (AMT_AMAGIC(amtp)) { |
2445
|
0
|
|
|
|
|
CV * const ret = amtp->table[id]; |
2446
|
0
|
0
|
|
|
|
if (ret && isGV(ret)) { /* Autoloading stab */ |
|
|
0
|
|
|
|
|
2447
|
|
|
|
|
|
/* Passing it through may have resulted in a warning |
2448
|
|
|
|
|
|
"Inherited AUTOLOAD for a non-method deprecated", since |
2449
|
|
|
|
|
|
our caller is going through a function call, not a method call. |
2450
|
|
|
|
|
|
So return the CV for AUTOLOAD, setting $AUTOLOAD. */ |
2451
|
0
|
|
|
|
|
GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]); |
2452
|
|
|
|
|
|
|
2453
|
0
|
0
|
|
|
|
if (gv && GvCV(gv)) |
|
|
0
|
|
|
|
|
2454
|
0
|
|
|
|
|
return GvCV(gv); |
2455
|
|
|
|
|
|
} |
2456
|
|
|
|
|
|
return ret; |
2457
|
|
|
|
|
|
} |
2458
|
|
|
|
|
|
|
2459
|
|
|
|
|
|
return NULL; |
2460
|
|
|
|
|
|
} |
2461
|
|
|
|
|
|
|
2462
|
|
|
|
|
|
|
2463
|
|
|
|
|
|
/* Implement tryAMAGICun_MG macro. |
2464
|
|
|
|
|
|
Do get magic, then see if the stack arg is overloaded and if so call it. |
2465
|
|
|
|
|
|
Flags: |
2466
|
|
|
|
|
|
AMGf_set return the arg using SETs rather than assigning to |
2467
|
|
|
|
|
|
the targ |
2468
|
|
|
|
|
|
AMGf_numeric apply sv_2num to the stack arg. |
2469
|
|
|
|
|
|
*/ |
2470
|
|
|
|
|
|
|
2471
|
|
|
|
|
|
bool |
2472
|
3276207
|
100
|
|
|
|
Perl_try_amagic_un(pTHX_ int method, int flags) { |
2473
|
|
|
|
|
|
dVAR; |
2474
|
2184138
|
|
|
|
|
dSP; |
2475
|
|
|
|
|
|
SV* tmpsv; |
2476
|
2184138
|
|
|
|
|
SV* const arg = TOPs; |
2477
|
|
|
|
|
|
|
2478
|
1099879
|
|
|
|
|
SvGETMAGIC(arg); |
2479
|
|
|
|
|
|
|
2480
|
2184138
|
100
|
|
|
|
if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method, |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2481
|
|
|
|
|
|
AMGf_noright | AMGf_unary))) { |
2482
|
7136
|
100
|
|
|
|
if (flags & AMGf_set) { |
2483
|
42
|
|
|
|
|
SETs(tmpsv); |
2484
|
|
|
|
|
|
} |
2485
|
|
|
|
|
|
else { |
2486
|
7094
|
|
|
|
|
dTARGET; |
2487
|
7094
|
100
|
|
|
|
if (SvPADMY(TARG)) { |
2488
|
246
|
|
|
|
|
sv_setsv(TARG, tmpsv); |
2489
|
246
|
50
|
|
|
|
SETTARG; |
2490
|
|
|
|
|
|
} |
2491
|
|
|
|
|
|
else |
2492
|
6848
|
|
|
|
|
SETs(tmpsv); |
2493
|
|
|
|
|
|
} |
2494
|
7136
|
|
|
|
|
PUTBACK; |
2495
|
7136
|
|
|
|
|
return TRUE; |
2496
|
|
|
|
|
|
} |
2497
|
|
|
|
|
|
|
2498
|
2176978
|
100
|
|
|
|
if ((flags & AMGf_numeric) && SvROK(arg)) |
|
|
100
|
|
|
|
|
2499
|
1092069
|
|
|
|
|
*sp = sv_2num(arg); |
2500
|
|
|
|
|
|
return FALSE; |
2501
|
|
|
|
|
|
} |
2502
|
|
|
|
|
|
|
2503
|
|
|
|
|
|
|
2504
|
|
|
|
|
|
/* Implement tryAMAGICbin_MG macro. |
2505
|
|
|
|
|
|
Do get magic, then see if the two stack args are overloaded and if so |
2506
|
|
|
|
|
|
call it. |
2507
|
|
|
|
|
|
Flags: |
2508
|
|
|
|
|
|
AMGf_set return the arg using SETs rather than assigning to |
2509
|
|
|
|
|
|
the targ |
2510
|
|
|
|
|
|
AMGf_assign op may be called as mutator (eg +=) |
2511
|
|
|
|
|
|
AMGf_numeric apply sv_2num to the stack arg. |
2512
|
|
|
|
|
|
*/ |
2513
|
|
|
|
|
|
|
2514
|
|
|
|
|
|
bool |
2515
|
14702824
|
100
|
|
|
|
Perl_try_amagic_bin(pTHX_ int method, int flags) { |
2516
|
|
|
|
|
|
dVAR; |
2517
|
9834277
|
|
|
|
|
dSP; |
2518
|
9834277
|
|
|
|
|
SV* const left = TOPm1s; |
2519
|
9834277
|
|
|
|
|
SV* const right = TOPs; |
2520
|
|
|
|
|
|
|
2521
|
10442455
|
|
|
|
|
SvGETMAGIC(left); |
2522
|
14701979
|
100
|
|
|
|
if (left != right) |
|
|
100
|
|
|
|
|
2523
|
6173616
|
|
|
|
|
SvGETMAGIC(right); |
2524
|
|
|
|
|
|
|
2525
|
9834271
|
100
|
|
|
|
if (SvAMAGIC(left) || SvAMAGIC(right)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2526
|
763216
|
100
|
|
|
|
SV * const tmpsv = amagic_call(left, right, method, |
|
|
100
|
|
|
|
|
2527
|
|
|
|
|
|
((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0)); |
2528
|
763058
|
100
|
|
|
|
if (tmpsv) { |
2529
|
473394
|
100
|
|
|
|
if (flags & AMGf_set) { |
2530
|
433414
|
|
|
|
|
(void)POPs; |
2531
|
433414
|
|
|
|
|
SETs(tmpsv); |
2532
|
|
|
|
|
|
} |
2533
|
|
|
|
|
|
else { |
2534
|
39980
|
100
|
|
|
|
dATARGET; |
2535
|
39980
|
|
|
|
|
(void)POPs; |
2536
|
39980
|
100
|
|
|
|
if (opASSIGN || SvPADMY(TARG)) { |
|
|
100
|
|
|
|
|
2537
|
16878
|
|
|
|
|
sv_setsv(TARG, tmpsv); |
2538
|
16878
|
50
|
|
|
|
SETTARG; |
2539
|
|
|
|
|
|
} |
2540
|
|
|
|
|
|
else |
2541
|
23102
|
|
|
|
|
SETs(tmpsv); |
2542
|
|
|
|
|
|
} |
2543
|
473394
|
|
|
|
|
PUTBACK; |
2544
|
473394
|
|
|
|
|
return TRUE; |
2545
|
|
|
|
|
|
} |
2546
|
|
|
|
|
|
} |
2547
|
9361101
|
100
|
|
|
|
if(left==right && SvGMAGICAL(left)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
2548
|
382
|
|
|
|
|
SV * const left = sv_newmortal(); |
2549
|
382
|
|
|
|
|
*(sp-1) = left; |
2550
|
|
|
|
|
|
/* Print the uninitialized warning now, so it includes the vari- |
2551
|
|
|
|
|
|
able name. */ |
2552
|
382
|
100
|
|
|
|
if (!SvOK(right)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2553
|
8
|
100
|
|
|
|
if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right); |
2554
|
8
|
|
|
|
|
sv_setsv_flags(left, &PL_sv_no, 0); |
2555
|
|
|
|
|
|
} |
2556
|
374
|
|
|
|
|
else sv_setsv_flags(left, right, 0); |
2557
|
573
|
|
|
|
|
SvGETMAGIC(right); |
2558
|
|
|
|
|
|
} |
2559
|
9360719
|
100
|
|
|
|
if (flags & AMGf_numeric) { |
2560
|
2388554
|
100
|
|
|
|
if (SvROK(TOPm1s)) |
2561
|
2332614
|
|
|
|
|
*(sp-1) = sv_2num(TOPm1s); |
2562
|
2388554
|
100
|
|
|
|
if (SvROK(right)) |
2563
|
6133216
|
|
|
|
|
*sp = sv_2num(right); |
2564
|
|
|
|
|
|
} |
2565
|
|
|
|
|
|
return FALSE; |
2566
|
|
|
|
|
|
} |
2567
|
|
|
|
|
|
|
2568
|
|
|
|
|
|
SV * |
2569
|
4751179
|
|
|
|
|
Perl_amagic_deref_call(pTHX_ SV *ref, int method) { |
2570
|
|
|
|
|
|
SV *tmpsv = NULL; |
2571
|
|
|
|
|
|
|
2572
|
|
|
|
|
|
PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL; |
2573
|
|
|
|
|
|
|
2574
|
7126538
|
100
|
|
|
|
while (SvAMAGIC(ref) && |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2575
|
|
|
|
|
|
(tmpsv = amagic_call(ref, &PL_sv_undef, method, |
2576
|
|
|
|
|
|
AMGf_noright | AMGf_unary))) { |
2577
|
4750615
|
100
|
|
|
|
if (!SvROK(tmpsv)) |
2578
|
60
|
|
|
|
|
Perl_croak(aTHX_ "Overloaded dereference did not return a reference"); |
2579
|
4750555
|
100
|
|
|
|
if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) { |
|
|
100
|
|
|
|
|
2580
|
|
|
|
|
|
/* Bail out if it returns us the same reference. */ |
2581
|
|
|
|
|
|
return tmpsv; |
2582
|
|
|
|
|
|
} |
2583
|
|
|
|
|
|
ref = tmpsv; |
2584
|
|
|
|
|
|
} |
2585
|
2376804
|
100
|
|
|
|
return tmpsv ? tmpsv : ref; |
2586
|
|
|
|
|
|
} |
2587
|
|
|
|
|
|
|
2588
|
|
|
|
|
|
bool |
2589
|
15278066
|
|
|
|
|
Perl_amagic_is_enabled(pTHX_ int method) |
2590
|
|
|
|
|
|
{ |
2591
|
15278066
|
|
|
|
|
SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0); |
2592
|
|
|
|
|
|
|
2593
|
|
|
|
|
|
assert(PL_curcop->cop_hints & HINT_NO_AMAGIC); |
2594
|
|
|
|
|
|
|
2595
|
15278066
|
50
|
|
|
|
if ( !lex_mask || !SvOK(lex_mask) ) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2596
|
|
|
|
|
|
/* overloading lexically disabled */ |
2597
|
|
|
|
|
|
return FALSE; |
2598
|
52
|
50
|
|
|
|
else if ( lex_mask && SvPOK(lex_mask) ) { |
|
|
50
|
|
|
|
|
2599
|
|
|
|
|
|
/* we have an entry in the hints hash, check if method has been |
2600
|
|
|
|
|
|
* masked by overloading.pm */ |
2601
|
|
|
|
|
|
STRLEN len; |
2602
|
52
|
|
|
|
|
const int offset = method / 8; |
2603
|
52
|
|
|
|
|
const int bit = method % 8; |
2604
|
52
|
50
|
|
|
|
char *pv = SvPV(lex_mask, len); |
2605
|
|
|
|
|
|
|
2606
|
|
|
|
|
|
/* Bit set, so this overloading operator is disabled */ |
2607
|
52
|
100
|
|
|
|
if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) ) |
|
|
100
|
|
|
|
|
2608
|
|
|
|
|
|
return FALSE; |
2609
|
|
|
|
|
|
} |
2610
|
7639049
|
|
|
|
|
return TRUE; |
2611
|
|
|
|
|
|
} |
2612
|
|
|
|
|
|
|
2613
|
|
|
|
|
|
SV* |
2614
|
20732645
|
|
|
|
|
Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) |
2615
|
|
|
|
|
|
{ |
2616
|
|
|
|
|
|
dVAR; |
2617
|
|
|
|
|
|
MAGIC *mg; |
2618
|
|
|
|
|
|
CV *cv=NULL; |
2619
|
|
|
|
|
|
CV **cvp=NULL, **ocvp=NULL; |
2620
|
|
|
|
|
|
AMT *amtp=NULL, *oamtp=NULL; |
2621
|
|
|
|
|
|
int off = 0, off1, lr = 0, notfound = 0; |
2622
|
|
|
|
|
|
int postpr = 0, force_cpy = 0; |
2623
|
20732645
|
|
|
|
|
int assign = AMGf_assign & flags; |
2624
|
20732645
|
|
|
|
|
const int assignshift = assign ? 1 : 0; |
2625
|
|
|
|
|
|
int use_default_op = 0; |
2626
|
|
|
|
|
|
int force_scalar = 0; |
2627
|
|
|
|
|
|
#ifdef DEBUGGING |
2628
|
|
|
|
|
|
int fl=0; |
2629
|
|
|
|
|
|
#endif |
2630
|
|
|
|
|
|
HV* stash=NULL; |
2631
|
|
|
|
|
|
|
2632
|
|
|
|
|
|
PERL_ARGS_ASSERT_AMAGIC_CALL; |
2633
|
|
|
|
|
|
|
2634
|
20732645
|
100
|
|
|
|
if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) { |
2635
|
15278038
|
100
|
|
|
|
if (!amagic_is_enabled(method)) return NULL; |
2636
|
|
|
|
|
|
} |
2637
|
|
|
|
|
|
|
2638
|
16341675
|
100
|
|
|
|
if (!(AMGf_noleft & flags) && SvAMAGIC(left) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2639
|
13610245
|
50
|
|
|
|
&& (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash) |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2640
|
4936956
|
50
|
|
|
|
&& (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) |
2641
|
7405074
|
50
|
|
|
|
&& (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) |
2642
|
9873912
|
|
|
|
|
? (oamtp = amtp = (AMT*)mg->mg_ptr)->table |
2643
|
7405074
|
50
|
|
|
|
: NULL)) |
2644
|
4936956
|
100
|
|
|
|
&& ((cv = cvp[off=method+assignshift]) |
2645
|
4481314
|
100
|
|
|
|
|| (assign && amtp->fallback > AMGfallNEVER && /* fallback to |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2646
|
|
|
|
|
|
* usual method */ |
2647
|
|
|
|
|
|
( |
2648
|
|
|
|
|
|
#ifdef DEBUGGING |
2649
|
|
|
|
|
|
fl = 1, |
2650
|
|
|
|
|
|
#endif |
2651
|
44
|
|
|
|
|
cv = cvp[off=method])))) { |
2652
|
|
|
|
|
|
lr = -1; /* Call method for left argument */ |
2653
|
|
|
|
|
|
} else { |
2654
|
4998959
|
100
|
|
|
|
if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2655
|
|
|
|
|
|
int logic; |
2656
|
|
|
|
|
|
|
2657
|
|
|
|
|
|
/* look for substituted methods */ |
2658
|
|
|
|
|
|
/* In all the covered cases we should be called with assign==0. */ |
2659
|
4362597
|
100
|
|
|
|
switch (method) { |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2660
|
|
|
|
|
|
case inc_amg: |
2661
|
|
|
|
|
|
force_cpy = 1; |
2662
|
22
|
50
|
|
|
|
if ((cv = cvp[off=add_ass_amg]) |
2663
|
0
|
0
|
|
|
|
|| ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) { |
2664
|
|
|
|
|
|
right = &PL_sv_yes; lr = -1; assign = 1; |
2665
|
|
|
|
|
|
} |
2666
|
|
|
|
|
|
break; |
2667
|
|
|
|
|
|
case dec_amg: |
2668
|
|
|
|
|
|
force_cpy = 1; |
2669
|
24
|
50
|
|
|
|
if ((cv = cvp[off = subtr_ass_amg]) |
2670
|
0
|
0
|
|
|
|
|| ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) { |
2671
|
|
|
|
|
|
right = &PL_sv_yes; lr = -1; assign = 1; |
2672
|
|
|
|
|
|
} |
2673
|
|
|
|
|
|
break; |
2674
|
|
|
|
|
|
case bool__amg: |
2675
|
2677
|
|
|
|
|
(void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); |
2676
|
|
|
|
|
|
break; |
2677
|
|
|
|
|
|
case numer_amg: |
2678
|
13
|
|
|
|
|
(void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])); |
2679
|
|
|
|
|
|
break; |
2680
|
|
|
|
|
|
case string_amg: |
2681
|
564
|
|
|
|
|
(void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); |
2682
|
|
|
|
|
|
break; |
2683
|
|
|
|
|
|
case not_amg: |
2684
|
42
|
|
|
|
|
(void)((cv = cvp[off=bool__amg]) |
2685
|
28
|
100
|
|
|
|
|| (cv = cvp[off=numer_amg]) |
2686
|
18
|
|
|
|
|
|| (cv = cvp[off=string_amg])); |
2687
|
42
|
50
|
|
|
|
if (cv) |
2688
|
|
|
|
|
|
postpr = 1; |
2689
|
|
|
|
|
|
break; |
2690
|
|
|
|
|
|
case copy_amg: |
2691
|
|
|
|
|
|
{ |
2692
|
|
|
|
|
|
/* |
2693
|
|
|
|
|
|
* SV* ref causes confusion with the interpreter variable of |
2694
|
|
|
|
|
|
* the same name |
2695
|
|
|
|
|
|
*/ |
2696
|
2
|
|
|
|
|
SV* const tmpRef=SvRV(left); |
2697
|
2
|
50
|
|
|
|
if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) { |
|
|
50
|
|
|
|
|
2698
|
|
|
|
|
|
/* |
2699
|
|
|
|
|
|
* Just to be extra cautious. Maybe in some |
2700
|
|
|
|
|
|
* additional cases sv_setsv is safe, too. |
2701
|
|
|
|
|
|
*/ |
2702
|
2
|
|
|
|
|
SV* const newref = newSVsv(tmpRef); |
2703
|
2
|
|
|
|
|
SvOBJECT_on(newref); |
2704
|
|
|
|
|
|
/* No need to do SvAMAGIC_on here, as SvAMAGIC macros |
2705
|
|
|
|
|
|
delegate to the stash. */ |
2706
|
4
|
|
|
|
|
SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef)))); |
2707
|
2
|
|
|
|
|
return newref; |
2708
|
|
|
|
|
|
} |
2709
|
|
|
|
|
|
} |
2710
|
|
|
|
|
|
break; |
2711
|
|
|
|
|
|
case abs_amg: |
2712
|
8
|
50
|
|
|
|
if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) |
|
|
50
|
|
|
|
|
2713
|
0
|
0
|
|
|
|
&& ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { |
|
|
0
|
|
|
|
|
2714
|
0
|
|
|
|
|
SV* const nullsv=sv_2mortal(newSViv(0)); |
2715
|
0
|
0
|
|
|
|
if (off1==lt_amg) { |
2716
|
0
|
|
|
|
|
SV* const lessp = amagic_call(left,nullsv, |
2717
|
|
|
|
|
|
lt_amg,AMGf_noright); |
2718
|
0
|
0
|
|
|
|
logic = SvTRUE(lessp); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
2719
|
|
|
|
|
|
} else { |
2720
|
0
|
|
|
|
|
SV* const lessp = amagic_call(left,nullsv, |
2721
|
|
|
|
|
|
ncmp_amg,AMGf_noright); |
2722
|
0
|
0
|
|
|
|
logic = (SvNV(lessp) < 0); |
2723
|
|
|
|
|
|
} |
2724
|
0
|
0
|
|
|
|
if (logic) { |
2725
|
0
|
0
|
|
|
|
if (off==subtr_amg) { |
2726
|
|
|
|
|
|
right = left; |
2727
|
|
|
|
|
|
left = nullsv; |
2728
|
|
|
|
|
|
lr = 1; |
2729
|
|
|
|
|
|
} |
2730
|
|
|
|
|
|
} else { |
2731
|
|
|
|
|
|
return left; |
2732
|
|
|
|
|
|
} |
2733
|
|
|
|
|
|
} |
2734
|
|
|
|
|
|
break; |
2735
|
|
|
|
|
|
case neg_amg: |
2736
|
8
|
50
|
|
|
|
if ((cv = cvp[off=subtr_amg])) { |
2737
|
|
|
|
|
|
right = left; |
2738
|
0
|
|
|
|
|
left = sv_2mortal(newSViv(0)); |
2739
|
|
|
|
|
|
lr = 1; |
2740
|
|
|
|
|
|
} |
2741
|
|
|
|
|
|
break; |
2742
|
|
|
|
|
|
case int_amg: |
2743
|
|
|
|
|
|
case iter_amg: /* XXXX Eventually should do to_gv. */ |
2744
|
|
|
|
|
|
case ftest_amg: /* XXXX Eventually should do to_gv. */ |
2745
|
|
|
|
|
|
case regexp_amg: |
2746
|
|
|
|
|
|
/* FAIL safe */ |
2747
|
|
|
|
|
|
return NULL; /* Delegate operation to standard mechanisms. */ |
2748
|
|
|
|
|
|
break; |
2749
|
|
|
|
|
|
case to_sv_amg: |
2750
|
|
|
|
|
|
case to_av_amg: |
2751
|
|
|
|
|
|
case to_hv_amg: |
2752
|
|
|
|
|
|
case to_gv_amg: |
2753
|
|
|
|
|
|
case to_cv_amg: |
2754
|
|
|
|
|
|
/* FAIL safe */ |
2755
|
4358778
|
|
|
|
|
return left; /* Delegate operation to standard mechanisms. */ |
2756
|
|
|
|
|
|
break; |
2757
|
|
|
|
|
|
default: |
2758
|
|
|
|
|
|
goto not_found; |
2759
|
|
|
|
|
|
} |
2760
|
2316
|
100
|
|
|
|
if (!cv) goto not_found; |
2761
|
669045
|
100
|
|
|
|
} else if (!(AMGf_noright & flags) && SvAMAGIC(right) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2762
|
39445
|
50
|
|
|
|
&& (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2763
|
15764
|
50
|
|
|
|
&& (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) |
2764
|
23646
|
50
|
|
|
|
&& (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) |
2765
|
31528
|
|
|
|
|
? (amtp = (AMT*)mg->mg_ptr)->table |
2766
|
23646
|
50
|
|
|
|
: NULL)) |
2767
|
15764
|
100
|
|
|
|
&& (cv = cvp[off=method])) { /* Method for right |
2768
|
|
|
|
|
|
* argument found */ |
2769
|
|
|
|
|
|
lr=1; |
2770
|
635267
|
100
|
|
|
|
} else if (((cvp && amtp->fallback > AMGfallNEVER) |
|
|
50
|
|
|
|
|
2771
|
506579
|
50
|
|
|
|
|| (ocvp && oamtp->fallback > AMGfallNEVER)) |
|
|
0
|
|
|
|
|
2772
|
128688
|
50
|
|
|
|
&& !(flags & AMGf_unary)) { |
2773
|
|
|
|
|
|
/* We look for substitution for |
2774
|
|
|
|
|
|
* comparison operations and |
2775
|
|
|
|
|
|
* concatenation */ |
2776
|
192852
|
100
|
|
|
|
if (method==concat_amg || method==concat_ass_amg |
2777
|
187076
|
50
|
|
|
|
|| method==repeat_amg || method==repeat_ass_amg) { |
2778
|
|
|
|
|
|
return NULL; /* Delegate operation to string conversion */ |
2779
|
|
|
|
|
|
} |
2780
|
|
|
|
|
|
off = -1; |
2781
|
122912
|
100
|
|
|
|
switch (method) { |
2782
|
|
|
|
|
|
case lt_amg: |
2783
|
|
|
|
|
|
case le_amg: |
2784
|
|
|
|
|
|
case gt_amg: |
2785
|
|
|
|
|
|
case ge_amg: |
2786
|
|
|
|
|
|
case eq_amg: |
2787
|
|
|
|
|
|
case ne_amg: |
2788
|
|
|
|
|
|
off = ncmp_amg; |
2789
|
|
|
|
|
|
break; |
2790
|
|
|
|
|
|
case slt_amg: |
2791
|
|
|
|
|
|
case sle_amg: |
2792
|
|
|
|
|
|
case sgt_amg: |
2793
|
|
|
|
|
|
case sge_amg: |
2794
|
|
|
|
|
|
case seq_amg: |
2795
|
|
|
|
|
|
case sne_amg: |
2796
|
|
|
|
|
|
off = scmp_amg; |
2797
|
|
|
|
|
|
break; |
2798
|
|
|
|
|
|
} |
2799
|
122912
|
100
|
|
|
|
if (off != -1) { |
2800
|
120680
|
100
|
|
|
|
if (ocvp && (oamtp->fallback > AMGfallNEVER)) { |
|
|
50
|
|
|
|
|
2801
|
117648
|
|
|
|
|
cv = ocvp[off]; |
2802
|
|
|
|
|
|
lr = -1; |
2803
|
|
|
|
|
|
} |
2804
|
120680
|
100
|
|
|
|
if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2805
|
4362
|
|
|
|
|
cv = cvp[off]; |
2806
|
|
|
|
|
|
lr = 1; |
2807
|
|
|
|
|
|
} |
2808
|
|
|
|
|
|
} |
2809
|
122912
|
100
|
|
|
|
if (cv) |
2810
|
|
|
|
|
|
postpr = 1; |
2811
|
|
|
|
|
|
else |
2812
|
|
|
|
|
|
goto not_found; |
2813
|
|
|
|
|
|
} else { |
2814
|
|
|
|
|
|
not_found: /* No method found, either report or croak */ |
2815
|
510527
|
100
|
|
|
|
switch (method) { |
2816
|
|
|
|
|
|
case to_sv_amg: |
2817
|
|
|
|
|
|
case to_av_amg: |
2818
|
|
|
|
|
|
case to_hv_amg: |
2819
|
|
|
|
|
|
case to_gv_amg: |
2820
|
|
|
|
|
|
case to_cv_amg: |
2821
|
|
|
|
|
|
/* FAIL safe */ |
2822
|
|
|
|
|
|
return left; /* Delegate operation to standard mechanisms. */ |
2823
|
|
|
|
|
|
break; |
2824
|
|
|
|
|
|
} |
2825
|
119298
|
100
|
|
|
|
if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ |
|
|
100
|
|
|
|
|
2826
|
|
|
|
|
|
notfound = 1; lr = -1; |
2827
|
119294
|
100
|
|
|
|
} else if (cvp && (cv=cvp[nomethod_amg])) { |
|
|
100
|
|
|
|
|
2828
|
|
|
|
|
|
notfound = 1; lr = 1; |
2829
|
238584
|
100
|
|
|
|
} else if ((use_default_op = |
|
|
100
|
|
|
|
|
2830
|
3540
|
100
|
|
|
|
(!ocvp || oamtp->fallback >= AMGfallYES) |
2831
|
119286
|
100
|
|
|
|
&& (!cvp || amtp->fallback >= AMGfallYES)) |
|
|
50
|
|
|
|
|
2832
|
|
|
|
|
|
&& !DEBUG_o_TEST) { |
2833
|
|
|
|
|
|
/* Skip generating the "no method found" message. */ |
2834
|
|
|
|
|
|
return NULL; |
2835
|
|
|
|
|
|
} else { |
2836
|
|
|
|
|
|
SV *msg; |
2837
|
|
|
|
|
|
if (off==-1) off=method; |
2838
|
12
|
50
|
|
|
|
msg = sv_2mortal(Perl_newSVpvf(aTHX_ |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2839
|
|
|
|
|
|
"Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf, |
2840
|
|
|
|
|
|
AMG_id2name(method + assignshift), |
2841
|
|
|
|
|
|
(flags & AMGf_unary ? " " : "\n\tleft "), |
2842
|
|
|
|
|
|
SvAMAGIC(left)? |
2843
|
|
|
|
|
|
"in overloaded package ": |
2844
|
|
|
|
|
|
"has no overloaded magic", |
2845
|
|
|
|
|
|
SvAMAGIC(left)? |
2846
|
|
|
|
|
|
SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))): |
2847
|
|
|
|
|
|
SVfARG(&PL_sv_no), |
2848
|
|
|
|
|
|
SvAMAGIC(right)? |
2849
|
|
|
|
|
|
",\n\tright argument in overloaded package ": |
2850
|
|
|
|
|
|
(flags & AMGf_unary |
2851
|
|
|
|
|
|
? "" |
2852
|
|
|
|
|
|
: ",\n\tright argument has no overloaded magic"), |
2853
|
|
|
|
|
|
SvAMAGIC(right)? |
2854
|
|
|
|
|
|
SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))): |
2855
|
|
|
|
|
|
SVfARG(&PL_sv_no))); |
2856
|
12
|
50
|
|
|
|
if (use_default_op) { |
2857
|
|
|
|
|
|
DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) ); |
2858
|
|
|
|
|
|
} else { |
2859
|
12
|
|
|
|
|
Perl_croak(aTHX_ "%"SVf, SVfARG(msg)); |
2860
|
|
|
|
|
|
} |
2861
|
|
|
|
|
|
return NULL; |
2862
|
|
|
|
|
|
} |
2863
|
6
|
|
|
|
|
force_cpy = force_cpy || assign; |
2864
|
|
|
|
|
|
} |
2865
|
|
|
|
|
|
} |
2866
|
|
|
|
|
|
|
2867
|
579186
|
|
|
|
|
switch (method) { |
2868
|
|
|
|
|
|
/* in these cases, we're calling '+' or '-' as a fallback for a ++ or -- |
2869
|
|
|
|
|
|
* operation. we need this to return a value, so that it can be assigned |
2870
|
|
|
|
|
|
* later on, in the postpr block (case inc_amg/dec_amg), even if the |
2871
|
|
|
|
|
|
* increment or decrement was itself called in void context */ |
2872
|
|
|
|
|
|
case inc_amg: |
2873
|
206
|
50
|
|
|
|
if (off == add_amg) |
2874
|
|
|
|
|
|
force_scalar = 1; |
2875
|
|
|
|
|
|
break; |
2876
|
|
|
|
|
|
case dec_amg: |
2877
|
256
|
50
|
|
|
|
if (off == subtr_amg) |
2878
|
|
|
|
|
|
force_scalar = 1; |
2879
|
|
|
|
|
|
break; |
2880
|
|
|
|
|
|
/* in these cases, we're calling an assignment variant of an operator |
2881
|
|
|
|
|
|
* (+= rather than +, for instance). regardless of whether it's a |
2882
|
|
|
|
|
|
* fallback or not, it always has to return a value, which will be |
2883
|
|
|
|
|
|
* assigned to the proper variable later */ |
2884
|
|
|
|
|
|
case add_amg: |
2885
|
|
|
|
|
|
case subtr_amg: |
2886
|
|
|
|
|
|
case mult_amg: |
2887
|
|
|
|
|
|
case div_amg: |
2888
|
|
|
|
|
|
case modulo_amg: |
2889
|
|
|
|
|
|
case pow_amg: |
2890
|
|
|
|
|
|
case lshift_amg: |
2891
|
|
|
|
|
|
case rshift_amg: |
2892
|
|
|
|
|
|
case repeat_amg: |
2893
|
|
|
|
|
|
case concat_amg: |
2894
|
|
|
|
|
|
case band_amg: |
2895
|
|
|
|
|
|
case bor_amg: |
2896
|
|
|
|
|
|
case bxor_amg: |
2897
|
39908
|
100
|
|
|
|
if (assign) |
2898
|
|
|
|
|
|
force_scalar = 1; |
2899
|
|
|
|
|
|
break; |
2900
|
|
|
|
|
|
/* the copy constructor always needs to return a value */ |
2901
|
|
|
|
|
|
case copy_amg: |
2902
|
|
|
|
|
|
force_scalar = 1; |
2903
|
366
|
|
|
|
|
break; |
2904
|
|
|
|
|
|
/* because of the way these are implemented (they don't perform the |
2905
|
|
|
|
|
|
* dereferencing themselves, they return a reference that perl then |
2906
|
|
|
|
|
|
* dereferences later), they always have to be in scalar context */ |
2907
|
|
|
|
|
|
case to_sv_amg: |
2908
|
|
|
|
|
|
case to_av_amg: |
2909
|
|
|
|
|
|
case to_hv_amg: |
2910
|
|
|
|
|
|
case to_gv_amg: |
2911
|
|
|
|
|
|
case to_cv_amg: |
2912
|
|
|
|
|
|
force_scalar = 1; |
2913
|
608
|
|
|
|
|
break; |
2914
|
|
|
|
|
|
/* these don't have an op of their own; they're triggered by their parent |
2915
|
|
|
|
|
|
* op, so the context there isn't meaningful ('$a and foo()' in void |
2916
|
|
|
|
|
|
* context still needs to pass scalar context on to $a's bool overload) */ |
2917
|
|
|
|
|
|
case bool__amg: |
2918
|
|
|
|
|
|
case numer_amg: |
2919
|
|
|
|
|
|
case string_amg: |
2920
|
|
|
|
|
|
force_scalar = 1; |
2921
|
94316
|
|
|
|
|
break; |
2922
|
|
|
|
|
|
} |
2923
|
|
|
|
|
|
|
2924
|
|
|
|
|
|
#ifdef DEBUGGING |
2925
|
|
|
|
|
|
if (!notfound) { |
2926
|
|
|
|
|
|
DEBUG_o(Perl_deb(aTHX_ |
2927
|
|
|
|
|
|
"Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n", |
2928
|
|
|
|
|
|
AMG_id2name(off), |
2929
|
|
|
|
|
|
method+assignshift==off? "" : |
2930
|
|
|
|
|
|
" (initially \"", |
2931
|
|
|
|
|
|
method+assignshift==off? "" : |
2932
|
|
|
|
|
|
AMG_id2name(method+assignshift), |
2933
|
|
|
|
|
|
method+assignshift==off? "" : "\")", |
2934
|
|
|
|
|
|
flags & AMGf_unary? "" : |
2935
|
|
|
|
|
|
lr==1 ? " for right argument": " for left argument", |
2936
|
|
|
|
|
|
flags & AMGf_unary? " for argument" : "", |
2937
|
|
|
|
|
|
stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)), |
2938
|
|
|
|
|
|
fl? ",\n\tassignment variant used": "") ); |
2939
|
|
|
|
|
|
} |
2940
|
|
|
|
|
|
#endif |
2941
|
|
|
|
|
|
/* Since we use shallow copy during assignment, we need |
2942
|
|
|
|
|
|
* to dublicate the contents, probably calling user-supplied |
2943
|
|
|
|
|
|
* version of copy operator |
2944
|
|
|
|
|
|
*/ |
2945
|
|
|
|
|
|
/* We need to copy in following cases: |
2946
|
|
|
|
|
|
* a) Assignment form was called. |
2947
|
|
|
|
|
|
* assignshift==1, assign==T, method + 1 == off |
2948
|
|
|
|
|
|
* b) Increment or decrement, called directly. |
2949
|
|
|
|
|
|
* assignshift==0, assign==0, method + 0 == off |
2950
|
|
|
|
|
|
* c) Increment or decrement, translated to assignment add/subtr. |
2951
|
|
|
|
|
|
* assignshift==0, assign==T, |
2952
|
|
|
|
|
|
* force_cpy == T |
2953
|
|
|
|
|
|
* d) Increment or decrement, translated to nomethod. |
2954
|
|
|
|
|
|
* assignshift==0, assign==0, |
2955
|
|
|
|
|
|
* force_cpy == T |
2956
|
|
|
|
|
|
* e) Assignment form translated to nomethod. |
2957
|
|
|
|
|
|
* assignshift==1, assign==T, method + 1 != off |
2958
|
|
|
|
|
|
* force_cpy == T |
2959
|
|
|
|
|
|
*/ |
2960
|
|
|
|
|
|
/* off is method, method+assignshift, or a result of opcode substitution. |
2961
|
|
|
|
|
|
* In the latter case assignshift==0, so only notfound case is important. |
2962
|
|
|
|
|
|
*/ |
2963
|
579186
|
100
|
|
|
|
if ( (lr == -1) && ( ( (method + assignshift == off) |
|
|
100
|
|
|
|
|
2964
|
455664
|
100
|
|
|
|
&& (assign || (method == inc_amg) || (method == dec_amg))) |
|
|
100
|
|
|
|
|
2965
|
555478
|
100
|
|
|
|
|| force_cpy) ) |
2966
|
|
|
|
|
|
{ |
2967
|
|
|
|
|
|
/* newSVsv does not behave as advertised, so we copy missing |
2968
|
|
|
|
|
|
* information by hand */ |
2969
|
16612
|
|
|
|
|
SV *tmpRef = SvRV(left); |
2970
|
|
|
|
|
|
SV *rv_copy; |
2971
|
16612
|
100
|
|
|
|
if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) { |
|
|
50
|
|
|
|
|
2972
|
368
|
|
|
|
|
SvRV_set(left, rv_copy); |
2973
|
368
|
50
|
|
|
|
SvSETMAGIC(left); |
2974
|
368
|
|
|
|
|
SvREFCNT_dec_NN(tmpRef); |
2975
|
|
|
|
|
|
} |
2976
|
|
|
|
|
|
} |
2977
|
|
|
|
|
|
|
2978
|
579186
|
50
|
|
|
|
{ |
2979
|
579186
|
|
|
|
|
dSP; |
2980
|
|
|
|
|
|
BINOP myop; |
2981
|
|
|
|
|
|
SV* res; |
2982
|
579186
|
|
|
|
|
const bool oldcatch = CATCH_GET; |
2983
|
|
|
|
|
|
I32 oldmark, nret; |
2984
|
579186
|
100
|
|
|
|
int gimme = force_scalar ? G_SCALAR : GIMME_V; |
|
|
50
|
|
|
|
|
2985
|
|
|
|
|
|
|
2986
|
579186
|
|
|
|
|
CATCH_SET(TRUE); |
2987
|
|
|
|
|
|
Zero(&myop, 1, BINOP); |
2988
|
579186
|
|
|
|
|
myop.op_last = (OP *) &myop; |
2989
|
579186
|
|
|
|
|
myop.op_next = NULL; |
2990
|
579186
|
|
|
|
|
myop.op_flags = OPf_STACKED; |
2991
|
|
|
|
|
|
|
2992
|
579186
|
|
|
|
|
switch (gimme) { |
2993
|
|
|
|
|
|
case G_VOID: |
2994
|
212
|
|
|
|
|
myop.op_flags |= OPf_WANT_VOID; |
2995
|
212
|
|
|
|
|
break; |
2996
|
|
|
|
|
|
case G_ARRAY: |
2997
|
26
|
50
|
|
|
|
if (flags & AMGf_want_list) { |
2998
|
0
|
|
|
|
|
myop.op_flags |= OPf_WANT_LIST; |
2999
|
0
|
|
|
|
|
break; |
3000
|
|
|
|
|
|
} |
3001
|
|
|
|
|
|
/* FALLTHROUGH */ |
3002
|
|
|
|
|
|
default: |
3003
|
578974
|
|
|
|
|
myop.op_flags |= OPf_WANT_SCALAR; |
3004
|
578974
|
|
|
|
|
break; |
3005
|
|
|
|
|
|
} |
3006
|
|
|
|
|
|
|
3007
|
579186
|
100
|
|
|
|
PUSHSTACKi(PERLSI_OVERLOAD); |
3008
|
579186
|
|
|
|
|
ENTER; |
3009
|
579186
|
|
|
|
|
SAVEOP(); |
3010
|
579186
|
|
|
|
|
PL_op = (OP *) &myop; |
3011
|
579186
|
100
|
|
|
|
if (PERLDB_SUB && PL_curstash != PL_debstash) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
3012
|
4
|
|
|
|
|
PL_op->op_private |= OPpENTERSUB_DB; |
3013
|
579186
|
|
|
|
|
PUTBACK; |
3014
|
579186
|
|
|
|
|
Perl_pp_pushmark(aTHX); |
3015
|
|
|
|
|
|
|
3016
|
289233
|
|
|
|
|
EXTEND(SP, notfound + 5); |
3017
|
579186
|
100
|
|
|
|
PUSHs(lr>0? right: left); |
3018
|
579186
|
100
|
|
|
|
PUSHs(lr>0? left: right); |
3019
|
579186
|
100
|
|
|
|
PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); |
|
|
100
|
|
|
|
|
3020
|
579186
|
100
|
|
|
|
if (notfound) { |
3021
|
6
|
|
|
|
|
PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift), |
3022
|
|
|
|
|
|
AMG_id2namelen(method + assignshift), SVs_TEMP)); |
3023
|
|
|
|
|
|
} |
3024
|
579186
|
|
|
|
|
PUSHs(MUTABLE_SV(cv)); |
3025
|
579186
|
|
|
|
|
PUTBACK; |
3026
|
579186
|
|
|
|
|
oldmark = TOPMARK; |
3027
|
|
|
|
|
|
|
3028
|
579186
|
100
|
|
|
|
if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) |
3029
|
439340
|
|
|
|
|
CALLRUNOPS(aTHX); |
3030
|
578970
|
|
|
|
|
LEAVE; |
3031
|
578970
|
|
|
|
|
SPAGAIN; |
3032
|
578970
|
|
|
|
|
nret = SP - (PL_stack_base + oldmark); |
3033
|
|
|
|
|
|
|
3034
|
578970
|
|
|
|
|
switch (gimme) { |
3035
|
|
|
|
|
|
case G_VOID: |
3036
|
|
|
|
|
|
/* returning NULL has another meaning, and we check the context |
3037
|
|
|
|
|
|
* at the call site too, so this can be differentiated from the |
3038
|
|
|
|
|
|
* scalar case */ |
3039
|
|
|
|
|
|
res = &PL_sv_undef; |
3040
|
212
|
|
|
|
|
SP = PL_stack_base + oldmark; |
3041
|
212
|
|
|
|
|
break; |
3042
|
|
|
|
|
|
case G_ARRAY: { |
3043
|
26
|
50
|
|
|
|
if (flags & AMGf_want_list) { |
3044
|
0
|
|
|
|
|
res = sv_2mortal((SV *)newAV()); |
3045
|
0
|
|
|
|
|
av_extend((AV *)res, nret); |
3046
|
0
|
0
|
|
|
|
while (nret--) |
3047
|
0
|
|
|
|
|
av_store((AV *)res, nret, POPs); |
3048
|
|
|
|
|
|
break; |
3049
|
|
|
|
|
|
} |
3050
|
|
|
|
|
|
/* FALLTHROUGH */ |
3051
|
|
|
|
|
|
} |
3052
|
|
|
|
|
|
default: |
3053
|
578758
|
|
|
|
|
res = POPs; |
3054
|
578758
|
|
|
|
|
break; |
3055
|
|
|
|
|
|
} |
3056
|
|
|
|
|
|
|
3057
|
578970
|
|
|
|
|
PUTBACK; |
3058
|
578970
|
50
|
|
|
|
POPSTACK; |
3059
|
578970
|
|
|
|
|
CATCH_SET(oldcatch); |
3060
|
|
|
|
|
|
|
3061
|
578970
|
100
|
|
|
|
if (postpr) { |
3062
|
|
|
|
|
|
int ans; |
3063
|
119368
|
|
|
|
|
switch (method) { |
3064
|
|
|
|
|
|
case le_amg: |
3065
|
|
|
|
|
|
case sle_amg: |
3066
|
160
|
50
|
|
|
|
ans=SvIV(res)<=0; break; |
3067
|
|
|
|
|
|
case lt_amg: |
3068
|
|
|
|
|
|
case slt_amg: |
3069
|
49494
|
50
|
|
|
|
ans=SvIV(res)<0; break; |
3070
|
|
|
|
|
|
case ge_amg: |
3071
|
|
|
|
|
|
case sge_amg: |
3072
|
28032
|
50
|
|
|
|
ans=SvIV(res)>=0; break; |
3073
|
|
|
|
|
|
case gt_amg: |
3074
|
|
|
|
|
|
case sgt_amg: |
3075
|
3220
|
50
|
|
|
|
ans=SvIV(res)>0; break; |
3076
|
|
|
|
|
|
case eq_amg: |
3077
|
|
|
|
|
|
case seq_amg: |
3078
|
38006
|
50
|
|
|
|
ans=SvIV(res)==0; break; |
3079
|
|
|
|
|
|
case ne_amg: |
3080
|
|
|
|
|
|
case sne_amg: |
3081
|
414
|
50
|
|
|
|
ans=SvIV(res)!=0; break; |
3082
|
|
|
|
|
|
case inc_amg: |
3083
|
|
|
|
|
|
case dec_amg: |
3084
|
0
|
0
|
|
|
|
SvSetSV(left,res); return left; |
3085
|
|
|
|
|
|
case not_amg: |
3086
|
42
|
50
|
|
|
|
ans=!SvTRUE(res); break; |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
3087
|
|
|
|
|
|
default: |
3088
|
|
|
|
|
|
ans=0; break; |
3089
|
|
|
|
|
|
} |
3090
|
119368
|
100
|
|
|
|
return boolSV(ans); |
3091
|
459602
|
100
|
|
|
|
} else if (method==copy_amg) { |
3092
|
366
|
50
|
|
|
|
if (!SvROK(res)) { |
3093
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Copy method did not return a reference"); |
3094
|
|
|
|
|
|
} |
3095
|
366
|
|
|
|
|
return SvREFCNT_inc(SvRV(res)); |
3096
|
|
|
|
|
|
} else { |
3097
|
|
|
|
|
|
return res; |
3098
|
|
|
|
|
|
} |
3099
|
|
|
|
|
|
} |
3100
|
|
|
|
|
|
} |
3101
|
|
|
|
|
|
|
3102
|
|
|
|
|
|
void |
3103
|
63309958
|
|
|
|
|
Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) |
3104
|
|
|
|
|
|
{ |
3105
|
|
|
|
|
|
dVAR; |
3106
|
|
|
|
|
|
U32 hash; |
3107
|
|
|
|
|
|
|
3108
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_NAME_SET; |
3109
|
|
|
|
|
|
|
3110
|
63309958
|
50
|
|
|
|
if (len > I32_MAX) |
3111
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len); |
3112
|
|
|
|
|
|
|
3113
|
63309958
|
50
|
|
|
|
if (!(flags & GV_ADD) && GvNAME_HEK(gv)) { |
|
|
0
|
|
|
|
|
3114
|
0
|
|
|
|
|
unshare_hek(GvNAME_HEK(gv)); |
3115
|
|
|
|
|
|
} |
3116
|
|
|
|
|
|
|
3117
|
63309958
|
|
|
|
|
PERL_HASH(hash, name, len); |
3118
|
63309958
|
100
|
|
|
|
GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash); |
3119
|
63309958
|
|
|
|
|
} |
3120
|
|
|
|
|
|
|
3121
|
|
|
|
|
|
/* |
3122
|
|
|
|
|
|
=for apidoc gv_try_downgrade |
3123
|
|
|
|
|
|
|
3124
|
|
|
|
|
|
If the typeglob C can be expressed more succinctly, by having |
3125
|
|
|
|
|
|
something other than a real GV in its place in the stash, replace it |
3126
|
|
|
|
|
|
with the optimised form. Basic requirements for this are that C |
3127
|
|
|
|
|
|
is a real typeglob, is sufficiently ordinary, and is only referenced |
3128
|
|
|
|
|
|
from its package. This function is meant to be used when a GV has been |
3129
|
|
|
|
|
|
looked up in part to see what was there, causing upgrading, but based |
3130
|
|
|
|
|
|
on what was found it turns out that the real GV isn't required after all. |
3131
|
|
|
|
|
|
|
3132
|
|
|
|
|
|
If C is a completely empty typeglob, it is deleted from the stash. |
3133
|
|
|
|
|
|
|
3134
|
|
|
|
|
|
If C is a typeglob containing only a sufficiently-ordinary constant |
3135
|
|
|
|
|
|
sub, the typeglob is replaced with a scalar-reference placeholder that |
3136
|
|
|
|
|
|
more compactly represents the same thing. |
3137
|
|
|
|
|
|
|
3138
|
|
|
|
|
|
=cut |
3139
|
|
|
|
|
|
*/ |
3140
|
|
|
|
|
|
|
3141
|
|
|
|
|
|
void |
3142
|
8451555
|
|
|
|
|
Perl_gv_try_downgrade(pTHX_ GV *gv) |
3143
|
|
|
|
|
|
{ |
3144
|
|
|
|
|
|
HV *stash; |
3145
|
|
|
|
|
|
CV *cv; |
3146
|
|
|
|
|
|
HEK *namehek; |
3147
|
|
|
|
|
|
SV **gvp; |
3148
|
|
|
|
|
|
PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE; |
3149
|
|
|
|
|
|
|
3150
|
|
|
|
|
|
/* XXX Why and where does this leave dangling pointers during global |
3151
|
|
|
|
|
|
destruction? */ |
3152
|
8451555
|
50
|
|
|
|
if (PL_phase == PERL_PHASE_DESTRUCT) return; |
3153
|
|
|
|
|
|
|
3154
|
15108260
|
100
|
|
|
|
if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) && |
|
|
100
|
|
|
|
|
3155
|
12496750
|
50
|
|
|
|
!SvOBJECT(gv) && !SvREADONLY(gv) && |
3156
|
16541945
|
50
|
|
|
|
isGV_with_GP(gv) && GvGP(gv) && |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
3157
|
16486596
|
100
|
|
|
|
!GvINTRO(gv) && GvREFCNT(gv) == 1 && |
|
|
100
|
|
|
|
|
3158
|
18073345
|
100
|
|
|
|
!GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) && |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
3159
|
9839138
|
50
|
|
|
|
GvEGVx(gv) == gv && (stash = GvSTASH(gv)))) |
|
|
50
|
|
|
|
|
3160
|
|
|
|
|
|
return; |
3161
|
6656597
|
100
|
|
|
|
if (SvMAGICAL(gv)) { |
3162
|
|
|
|
|
|
MAGIC *mg; |
3163
|
|
|
|
|
|
/* only backref magic is allowed */ |
3164
|
3561430
|
50
|
|
|
|
if (SvGMAGICAL(gv) || SvSMAGICAL(gv)) |
3165
|
|
|
|
|
|
return; |
3166
|
7122860
|
100
|
|
|
|
for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) { |
3167
|
3561430
|
50
|
|
|
|
if (mg->mg_type != PERL_MAGIC_backref) |
3168
|
|
|
|
|
|
return; |
3169
|
|
|
|
|
|
} |
3170
|
|
|
|
|
|
} |
3171
|
6656597
|
|
|
|
|
cv = GvCV(gv); |
3172
|
6656597
|
100
|
|
|
|
if (!cv) { |
3173
|
2233647
|
|
|
|
|
HEK *gvnhek = GvNAME_HEK(gv); |
3174
|
2233647
|
100
|
|
|
|
(void)hv_delete(stash, HEK_KEY(gvnhek), |
3175
|
|
|
|
|
|
HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD); |
3176
|
4422950
|
50
|
|
|
|
} else if (GvMULTI(gv) && cv && |
3177
|
6520070
|
100
|
|
|
|
!SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) && |
|
|
100
|
|
|
|
|
3178
|
6130891
|
100
|
|
|
|
CvSTASH(cv) == stash && CvGV(cv) == gv && |
|
|
100
|
|
|
|
|
3179
|
3377860
|
50
|
|
|
|
CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) && |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
3180
|
2772398
|
50
|
|
|
|
!CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) && |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
3181
|
2096938
|
50
|
|
|
|
(namehek = GvNAME_HEK(gv)) && |
3182
|
1421478
|
100
|
|
|
|
(gvp = hv_fetch(stash, HEK_KEY(namehek), |
3183
|
1421478
|
50
|
|
|
|
HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) && |
3184
|
1421478
|
|
|
|
|
*gvp == (SV*)gv) { |
3185
|
1421478
|
|
|
|
|
SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr); |
3186
|
1421478
|
|
|
|
|
const bool imported = !!GvIMPORTED_CV(gv); |
3187
|
1421478
|
|
|
|
|
SvREFCNT(gv) = 0; |
3188
|
1421478
|
|
|
|
|
sv_clear((SV*)gv); |
3189
|
1421478
|
|
|
|
|
SvREFCNT(gv) = 1; |
3190
|
1421478
|
|
|
|
|
SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported; |
3191
|
1421478
|
|
|
|
|
SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) - |
3192
|
|
|
|
|
|
STRUCT_OFFSET(XPVIV, xiv_iv)); |
3193
|
5081754
|
|
|
|
|
SvRV_set(gv, value); |
3194
|
|
|
|
|
|
} |
3195
|
|
|
|
|
|
} |
3196
|
|
|
|
|
|
|
3197
|
|
|
|
|
|
#include "XSUB.h" |
3198
|
|
|
|
|
|
|
3199
|
|
|
|
|
|
static void |
3200
|
44
|
|
|
|
|
core_xsub(pTHX_ CV* cv) |
3201
|
|
|
|
|
|
{ |
3202
|
44
|
|
|
|
|
Perl_croak(aTHX_ |
3203
|
44
|
|
|
|
|
"&CORE::%s cannot be called directly", GvNAME(CvGV(cv)) |
3204
|
|
|
|
|
|
); |
3205
|
63694458
|
|
|
|
|
} |
3206
|
|
|
|
|
|
|
3207
|
|
|
|
|
|
/* |
3208
|
|
|
|
|
|
* Local variables: |
3209
|
|
|
|
|
|
* c-indentation-style: bsd |
3210
|
|
|
|
|
|
* c-basic-offset: 4 |
3211
|
|
|
|
|
|
* indent-tabs-mode: nil |
3212
|
|
|
|
|
|
* End: |
3213
|
|
|
|
|
|
* |
3214
|
|
|
|
|
|
* ex: set ts=8 sts=4 sw=4 et: |
3215
|
|
|
|
|
|
*/ |