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 Handling
24 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
25 It is a structure that holds a pointer to a scalar, an array, a hash etc,
26 corresponding to $foo, @foo, %foo.
27
28 GVs are usually found as values in stashes (symbol table hashes) where
29 Perl stores its global variables.
30
31 =for apidoc Ayh||GV
32
33 =cut
34 */
35
36 #include "EXTERN.h"
37 #define PERL_IN_GV_C
38 #include "perl.h"
39 #include "overload.inc"
40 #include "keywords.h"
41 #include "feature.h"
42
43 static const char S_autoload[] = "AUTOLOAD";
44 #define S_autolen (sizeof("AUTOLOAD")-1)
45
46 GV *
Perl_gv_add_by_type(pTHX_ GV * gv,svtype type)47 Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
48 {
49 SV **where;
50
51 if (
52 !gv
53 || (
54 SvTYPE((const SV *)gv) != SVt_PVGV
55 && SvTYPE((const SV *)gv) != SVt_PVLV
56 )
57 ) {
58 const char *what;
59 if (type == SVt_PVIO) {
60 /*
61 * if it walks like a dirhandle, then let's assume that
62 * this is a dirhandle.
63 */
64 what = OP_IS_DIRHOP(PL_op->op_type) ?
65 "dirhandle" : "filehandle";
66 } else if (type == SVt_PVHV) {
67 what = "hash";
68 } else {
69 what = type == SVt_PVAV ? "array" : "scalar";
70 }
71 /* diag_listed_as: Bad symbol for filehandle */
72 Perl_croak(aTHX_ "Bad symbol for %s", what);
73 }
74
75 if (type == SVt_PVHV) {
76 where = (SV **)&GvHV(gv);
77 } else if (type == SVt_PVAV) {
78 where = (SV **)&GvAV(gv);
79 } else if (type == SVt_PVIO) {
80 where = (SV **)&GvIOp(gv);
81 } else {
82 where = &GvSV(gv);
83 }
84
85 if (!*where)
86 {
87 *where = newSV_type(type);
88 if (type == SVt_PVAV
89 && memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA"))
90 sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
91 }
92 return gv;
93 }
94
95 /*
96 =for apidoc gv_fetchfile
97 =for apidoc_item gv_fetchfile_flags
98
99 These return the debugger glob for the file (compiled by Perl) whose name is
100 given by the C<name> parameter.
101
102 There are currently exactly two differences between these functions.
103
104 The C<name> parameter to C<gv_fetchfile> is a C string, meaning it is
105 C<NUL>-terminated; whereas the C<name> parameter to C<gv_fetchfile_flags> is a
106 Perl string, whose length (in bytes) is passed in via the C<namelen> parameter
107 This means the name may contain embedded C<NUL> characters.
108 C<namelen> doesn't exist in plain C<gv_fetchfile>).
109
110 The other difference is that C<gv_fetchfile_flags> has an extra C<flags>
111 parameter, which is currently completely ignored, but allows for possible
112 future extensions.
113
114 =cut
115 */
116 GV *
Perl_gv_fetchfile(pTHX_ const char * name)117 Perl_gv_fetchfile(pTHX_ const char *name)
118 {
119 PERL_ARGS_ASSERT_GV_FETCHFILE;
120 return gv_fetchfile_flags(name, strlen(name), 0);
121 }
122
123 GV *
Perl_gv_fetchfile_flags(pTHX_ const char * const name,const STRLEN namelen,const U32 flags)124 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
125 const U32 flags)
126 {
127 char smallbuf[128];
128 char *tmpbuf;
129 const STRLEN tmplen = namelen + 2;
130 GV *gv;
131
132 PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
133 PERL_UNUSED_ARG(flags);
134
135 if (!PL_defstash)
136 return NULL;
137
138 if (tmplen <= sizeof smallbuf)
139 tmpbuf = smallbuf;
140 else
141 Newx(tmpbuf, tmplen, char);
142 /* This is where the debugger's %{"::_<$filename"} hash is created */
143 tmpbuf[0] = '_';
144 tmpbuf[1] = '<';
145 memcpy(tmpbuf + 2, name, namelen);
146 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
147 if (!isGV(gv)) {
148 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
149 #ifdef PERL_DONT_CREATE_GVSV
150 GvSV(gv) = newSVpvn(name, namelen);
151 #else
152 sv_setpvn(GvSV(gv), name, namelen);
153 #endif
154 }
155 if (PERLDB_LINE_OR_SAVESRC && !GvAV(gv))
156 hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile);
157 if (tmpbuf != smallbuf)
158 Safefree(tmpbuf);
159 return gv;
160 }
161
162 /*
163 =for apidoc gv_const_sv
164
165 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
166 inlining, or C<gv> is a placeholder reference that would be promoted to such
167 a typeglob, then returns the value returned by the sub. Otherwise, returns
168 C<NULL>.
169
170 =cut
171 */
172
173 SV *
Perl_gv_const_sv(pTHX_ GV * gv)174 Perl_gv_const_sv(pTHX_ GV *gv)
175 {
176 PERL_ARGS_ASSERT_GV_CONST_SV;
177 PERL_UNUSED_CONTEXT;
178
179 if (SvTYPE(gv) == SVt_PVGV)
180 return cv_const_sv(GvCVu(gv));
181 return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV && SvTYPE(SvRV(gv)) != SVt_PVCV ? SvRV(gv) : NULL;
182 }
183
184 GP *
Perl_newGP(pTHX_ GV * const gv)185 Perl_newGP(pTHX_ GV *const gv)
186 {
187 GP *gp;
188 U32 hash;
189 const char *file;
190 STRLEN len;
191 #ifndef USE_ITHREADS
192 GV *filegv;
193 #endif
194
195 PERL_ARGS_ASSERT_NEWGP;
196 Newxz(gp, 1, GP);
197 gp->gp_egv = gv; /* allow compiler to reuse gv after this */
198 #ifndef PERL_DONT_CREATE_GVSV
199 gp->gp_sv = newSV(0);
200 #endif
201
202 /* PL_curcop may be null here. E.g.,
203 INIT { bless {} and exit }
204 frees INIT before looking up DESTROY (and creating *DESTROY)
205 */
206 if (PL_curcop) {
207 gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
208 #ifdef USE_ITHREADS
209 if (CopFILE(PL_curcop)) {
210 file = CopFILE(PL_curcop);
211 len = strlen(file);
212 }
213 #else
214 filegv = CopFILEGV(PL_curcop);
215 if (filegv) {
216 file = GvNAME(filegv)+2;
217 len = GvNAMELEN(filegv)-2;
218 }
219 #endif
220 else goto no_file;
221 }
222 else {
223 no_file:
224 file = "";
225 len = 0;
226 }
227
228 PERL_HASH(hash, file, len);
229 gp->gp_file_hek = share_hek(file, len, hash);
230 gp->gp_refcnt = 1;
231
232 return gp;
233 }
234
235 /* Assign CvGV(cv) = gv, handling weak references.
236 * See also S_anonymise_cv_maybe */
237
238 void
Perl_cvgv_set(pTHX_ CV * cv,GV * gv)239 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
240 {
241 GV * const oldgv = CvNAMED(cv) ? NULL : SvANY(cv)->xcv_gv_u.xcv_gv;
242 HEK *hek;
243 PERL_ARGS_ASSERT_CVGV_SET;
244
245 if (oldgv == gv)
246 return;
247
248 if (oldgv) {
249 if (CvCVGV_RC(cv)) {
250 SvREFCNT_dec_NN(oldgv);
251 CvCVGV_RC_off(cv);
252 }
253 else {
254 sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
255 }
256 }
257 else if ((hek = CvNAME_HEK(cv))) {
258 unshare_hek(hek);
259 CvLEXICAL_off(cv);
260 }
261
262 CvNAMED_off(cv);
263 SvANY(cv)->xcv_gv_u.xcv_gv = gv;
264 assert(!CvCVGV_RC(cv));
265
266 if (!gv)
267 return;
268
269 if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
270 Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
271 else {
272 CvCVGV_RC_on(cv);
273 SvREFCNT_inc_simple_void_NN(gv);
274 }
275 }
276
277 /* Convert CvSTASH + CvNAME_HEK into a GV. Conceptually, all subs have a
278 GV, but for efficiency that GV may not in fact exist. This function,
279 called by CvGV, reifies it. */
280
281 GV *
Perl_cvgv_from_hek(pTHX_ CV * cv)282 Perl_cvgv_from_hek(pTHX_ CV *cv)
283 {
284 GV *gv;
285 SV **svp;
286 PERL_ARGS_ASSERT_CVGV_FROM_HEK;
287 assert(SvTYPE(cv) == SVt_PVCV);
288 if (!CvSTASH(cv)) return NULL;
289 ASSUME(CvNAME_HEK(cv));
290 svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0);
291 gv = MUTABLE_GV(svp && *svp ? *svp : newSV(0));
292 if (!isGV(gv))
293 gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)),
294 HEK_LEN(CvNAME_HEK(cv)),
295 SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv)));
296 if (!CvNAMED(cv)) { /* gv_init took care of it */
297 assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv);
298 return gv;
299 }
300 unshare_hek(CvNAME_HEK(cv));
301 CvNAMED_off(cv);
302 SvANY(cv)->xcv_gv_u.xcv_gv = gv;
303 if (svp && *svp) SvREFCNT_inc_simple_void_NN(gv);
304 CvCVGV_RC_on(cv);
305 return gv;
306 }
307
308 /* Assign CvSTASH(cv) = st, handling weak references. */
309
310 void
Perl_cvstash_set(pTHX_ CV * cv,HV * st)311 Perl_cvstash_set(pTHX_ CV *cv, HV *st)
312 {
313 HV *oldst = CvSTASH(cv);
314 PERL_ARGS_ASSERT_CVSTASH_SET;
315 if (oldst == st)
316 return;
317 if (oldst)
318 sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
319 SvANY(cv)->xcv_stash = st;
320 if (st)
321 Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
322 }
323
324 /*
325 =for apidoc gv_init_pvn
326
327 Converts a scalar into a typeglob. This is an incoercible typeglob;
328 assigning a reference to it will assign to one of its slots, instead of
329 overwriting it as happens with typeglobs created by C<SvSetSV>. Converting
330 any scalar that is C<SvOK()> may produce unpredictable results and is reserved
331 for perl's internal use.
332
333 C<gv> is the scalar to be converted.
334
335 C<stash> is the parent stash/package, if any.
336
337 C<name> and C<len> give the name. The name must be unqualified;
338 that is, it must not include the package name. If C<gv> is a
339 stash element, it is the caller's responsibility to ensure that the name
340 passed to this function matches the name of the element. If it does not
341 match, perl's internal bookkeeping will get out of sync.
342
343 C<flags> can be set to C<SVf_UTF8> if C<name> is a UTF-8 string, or
344 the return value of SvUTF8(sv). It can also take the
345 C<GV_ADDMULTI> flag, which means to pretend that the GV has been
346 seen before (i.e., suppress "Used once" warnings).
347
348 =for apidoc Amnh||GV_ADDMULTI
349
350 =for apidoc gv_init
351
352 The old form of C<gv_init_pvn()>. It does not work with UTF-8 strings, as it
353 has no flags parameter. If the C<multi> parameter is set, the
354 C<GV_ADDMULTI> flag will be passed to C<gv_init_pvn()>.
355
356 =for apidoc gv_init_pv
357
358 Same as C<gv_init_pvn()>, but takes a nul-terminated string for the name
359 instead of separate char * and length parameters.
360
361 =for apidoc gv_init_sv
362
363 Same as C<gv_init_pvn()>, but takes an SV * for the name instead of separate
364 char * and length parameters. C<flags> is currently unused.
365
366 =cut
367 */
368
369 void
Perl_gv_init_sv(pTHX_ GV * gv,HV * stash,SV * namesv,U32 flags)370 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
371 {
372 char *namepv;
373 STRLEN namelen;
374 PERL_ARGS_ASSERT_GV_INIT_SV;
375 namepv = SvPV(namesv, namelen);
376 if (SvUTF8(namesv))
377 flags |= SVf_UTF8;
378 gv_init_pvn(gv, stash, namepv, namelen, flags);
379 }
380
381 void
Perl_gv_init_pv(pTHX_ GV * gv,HV * stash,const char * name,U32 flags)382 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
383 {
384 PERL_ARGS_ASSERT_GV_INIT_PV;
385 gv_init_pvn(gv, stash, name, strlen(name), flags);
386 }
387
388 void
Perl_gv_init_pvn(pTHX_ GV * gv,HV * stash,const char * name,STRLEN len,U32 flags)389 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
390 {
391 const U32 old_type = SvTYPE(gv);
392 const bool doproto = old_type > SVt_NULL;
393 char * const proto = (doproto && SvPOK(gv))
394 ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
395 : NULL;
396 const STRLEN protolen = proto ? SvCUR(gv) : 0;
397 const U32 proto_utf8 = proto ? SvUTF8(gv) : 0;
398 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
399 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
400 const bool really_sub =
401 has_constant && SvTYPE(has_constant) == SVt_PVCV;
402 COP * const old = PL_curcop;
403
404 PERL_ARGS_ASSERT_GV_INIT_PVN;
405 assert (!(proto && has_constant));
406
407 if (has_constant) {
408 /* The constant has to be a scalar, array or subroutine. */
409 switch (SvTYPE(has_constant)) {
410 case SVt_PVHV:
411 case SVt_PVFM:
412 case SVt_PVIO:
413 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
414 sv_reftype(has_constant, 0));
415 NOT_REACHED; /* NOTREACHED */
416 break;
417
418 default: NOOP;
419 }
420 SvRV_set(gv, NULL);
421 SvROK_off(gv);
422 }
423
424
425 if (old_type < SVt_PVGV) {
426 if (old_type >= SVt_PV)
427 SvCUR_set(gv, 0);
428 sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
429 }
430 if (SvLEN(gv)) {
431 if (proto) {
432 SvPV_set(gv, NULL);
433 SvLEN_set(gv, 0);
434 SvPOK_off(gv);
435 } else
436 Safefree(SvPVX_mutable(gv));
437 }
438 SvIOK_off(gv);
439 isGV_with_GP_on(gv);
440
441 if (really_sub && !CvISXSUB(has_constant) && CvSTART(has_constant)
442 && ( CvSTART(has_constant)->op_type == OP_NEXTSTATE
443 || CvSTART(has_constant)->op_type == OP_DBSTATE))
444 PL_curcop = (COP *)CvSTART(has_constant);
445 GvGP_set(gv, Perl_newGP(aTHX_ gv));
446 PL_curcop = old;
447 GvSTASH(gv) = stash;
448 if (stash)
449 Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
450 gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
451 if (flags & GV_ADDMULTI || doproto) /* doproto means it */
452 GvMULTI_on(gv); /* _was_ mentioned */
453 if (really_sub) {
454 /* Not actually a constant. Just a regular sub. */
455 CV * const cv = (CV *)has_constant;
456 GvCV_set(gv,cv);
457 if (CvNAMED(cv) && CvSTASH(cv) == stash && (
458 CvNAME_HEK(cv) == GvNAME_HEK(gv)
459 || ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
460 && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
461 && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv))
462 && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv))
463 )
464 ))
465 CvGV_set(cv,gv);
466 }
467 else if (doproto) {
468 CV *cv;
469 if (has_constant) {
470 /* newCONSTSUB takes ownership of the reference from us. */
471 cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
472 /* In case op.c:S_process_special_blocks stole it: */
473 if (!GvCV(gv))
474 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
475 assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
476 /* If this reference was a copy of another, then the subroutine
477 must have been "imported", by a Perl space assignment to a GV
478 from a reference to CV. */
479 if (exported_constant)
480 GvIMPORTED_CV_on(gv);
481 CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
482 } else {
483 cv = newSTUB(gv,1);
484 }
485 if (proto) {
486 sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
487 SV_HAS_TRAILING_NUL);
488 if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
489 }
490 }
491 }
492
493 STATIC void
S_gv_init_svtype(pTHX_ GV * gv,const svtype sv_type)494 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
495 {
496 PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
497
498 switch (sv_type) {
499 case SVt_PVIO:
500 (void)GvIOn(gv);
501 break;
502 case SVt_PVAV:
503 (void)GvAVn(gv);
504 break;
505 case SVt_PVHV:
506 (void)GvHVn(gv);
507 break;
508 #ifdef PERL_DONT_CREATE_GVSV
509 case SVt_NULL:
510 case SVt_PVCV:
511 case SVt_PVFM:
512 case SVt_PVGV:
513 break;
514 default:
515 if(GvSVn(gv)) {
516 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
517 If we just cast GvSVn(gv) to void, it ignores evaluating it for
518 its side effect */
519 }
520 #endif
521 }
522 }
523
524 static void core_xsub(pTHX_ CV* cv);
525
526 static GV *
S_maybe_add_coresub(pTHX_ HV * const stash,GV * gv,const char * const name,const STRLEN len)527 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
528 const char * const name, const STRLEN len)
529 {
530 const int code = keyword(name, len, 1);
531 static const char file[] = __FILE__;
532 CV *cv, *oldcompcv = NULL;
533 int opnum = 0;
534 bool ampable = TRUE; /* &{}-able */
535 COP *oldcurcop = NULL;
536 yy_parser *oldparser = NULL;
537 I32 oldsavestack_ix = 0;
538
539 assert(gv || stash);
540 assert(name);
541
542 if (!code) return NULL; /* Not a keyword */
543 switch (code < 0 ? -code : code) {
544 /* no support for \&CORE::infix;
545 no support for funcs that do not parse like funcs */
546 case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
547 case KEY_BEGIN : case KEY_CHECK : case KEY_catch : case KEY_cmp:
548 case KEY_default : case KEY_defer : case KEY_DESTROY:
549 case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif :
550 case KEY_END : case KEY_eq : case KEY_eval :
551 case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge :
552 case KEY_given : case KEY_goto : case KEY_grep : case KEY_gt :
553 case KEY_if : case KEY_isa : case KEY_INIT : case KEY_last :
554 case KEY_le : case KEY_local : case KEY_lt : case KEY_m :
555 case KEY_map : case KEY_my:
556 case KEY_ne : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
557 case KEY_package: case KEY_print: case KEY_printf:
558 case KEY_q : case KEY_qq : case KEY_qr : case KEY_qw :
559 case KEY_qx : case KEY_redo : case KEY_require: case KEY_return:
560 case KEY_s : case KEY_say : case KEY_sort :
561 case KEY_state: case KEY_sub :
562 case KEY_tr : case KEY_try : case KEY_UNITCHECK: case KEY_unless:
563 case KEY_until: case KEY_use : case KEY_when : case KEY_while :
564 case KEY_x : case KEY_xor : case KEY_y :
565 return NULL;
566 case KEY_chdir:
567 case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
568 case KEY_eof : case KEY_exec: case KEY_exists :
569 case KEY_lstat:
570 case KEY_split:
571 case KEY_stat:
572 case KEY_system:
573 case KEY_truncate: case KEY_unlink:
574 ampable = FALSE;
575 }
576 if (!gv) {
577 gv = (GV *)newSV(0);
578 gv_init(gv, stash, name, len, TRUE);
579 }
580 GvMULTI_on(gv);
581 if (ampable) {
582 ENTER;
583 oldcurcop = PL_curcop;
584 oldparser = PL_parser;
585 lex_start(NULL, NULL, 0);
586 oldcompcv = PL_compcv;
587 PL_compcv = NULL; /* Prevent start_subparse from setting
588 CvOUTSIDE. */
589 oldsavestack_ix = start_subparse(FALSE,0);
590 cv = PL_compcv;
591 }
592 else {
593 /* Avoid calling newXS, as it calls us, and things start to
594 get hairy. */
595 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
596 GvCV_set(gv,cv);
597 GvCVGEN(gv) = 0;
598 CvISXSUB_on(cv);
599 CvXSUB(cv) = core_xsub;
600 PoisonPADLIST(cv);
601 }
602 CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
603 from PL_curcop. */
604 /* XSUBs can't be perl lang/perl5db.pl debugged
605 if (PERLDB_LINE_OR_SAVESRC)
606 (void)gv_fetchfile(file); */
607 CvFILE(cv) = (char *)file;
608 /* XXX This is inefficient, as doing things this order causes
609 a prototype check in newATTRSUB. But we have to do
610 it this order as we need an op number before calling
611 new ATTRSUB. */
612 (void)core_prototype((SV *)cv, name, code, &opnum);
613 if (stash)
614 (void)hv_store(stash,name,len,(SV *)gv,0);
615 if (ampable) {
616 #ifdef DEBUGGING
617 CV *orig_cv = cv;
618 #endif
619 CvLVALUE_on(cv);
620 /* newATTRSUB will free the CV and return NULL if we're still
621 compiling after a syntax error */
622 if ((cv = newATTRSUB_x(
623 oldsavestack_ix, (OP *)gv,
624 NULL,NULL,
625 coresub_op(
626 opnum
627 ? newSVuv((UV)opnum)
628 : newSVpvn(name,len),
629 code, opnum
630 ),
631 TRUE
632 )) != NULL) {
633 assert(GvCV(gv) == orig_cv);
634 if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
635 && opnum != OP_UNDEF && opnum != OP_KEYS)
636 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
637 }
638 LEAVE;
639 PL_parser = oldparser;
640 PL_curcop = oldcurcop;
641 PL_compcv = oldcompcv;
642 }
643 if (cv) {
644 SV *opnumsv = newSViv(
645 (opnum == OP_ENTEREVAL && len == 9 && memEQ(name, "evalbytes", 9)) ?
646 (OP_ENTEREVAL | (1<<16))
647 : opnum ? opnum : (((I32)name[2]) << 16));
648 cv_set_call_checker_flags(cv, Perl_ck_entersub_args_core, opnumsv, 0);
649 SvREFCNT_dec_NN(opnumsv);
650 }
651
652 return gv;
653 }
654
655 /*
656 =for apidoc gv_fetchmeth
657
658 Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
659
660 =for apidoc gv_fetchmeth_sv
661
662 Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
663 of an SV instead of a string/length pair.
664
665 =cut
666 */
667
668 GV *
Perl_gv_fetchmeth_sv(pTHX_ HV * stash,SV * namesv,I32 level,U32 flags)669 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
670 {
671 char *namepv;
672 STRLEN namelen;
673 PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
674 if (LIKELY(SvPOK_nog(namesv))) /* common case */
675 return gv_fetchmeth_internal(stash, namesv, NULL, 0, level,
676 flags | SvUTF8(namesv));
677 namepv = SvPV(namesv, namelen);
678 if (SvUTF8(namesv)) flags |= SVf_UTF8;
679 return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
680 }
681
682 /*
683 =for apidoc gv_fetchmeth_pv
684
685 Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string
686 instead of a string/length pair.
687
688 =cut
689 */
690
691 GV *
Perl_gv_fetchmeth_pv(pTHX_ HV * stash,const char * name,I32 level,U32 flags)692 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
693 {
694 PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
695 return gv_fetchmeth_internal(stash, NULL, name, strlen(name), level, flags);
696 }
697
698 /*
699 =for apidoc gv_fetchmeth_pvn
700
701 Returns the glob with the given C<name> and a defined subroutine or
702 C<NULL>. The glob lives in the given C<stash>, or in the stashes
703 accessible via C<@ISA> and C<UNIVERSAL::>.
704
705 The argument C<level> should be either 0 or -1. If C<level==0>, as a
706 side-effect creates a glob with the given C<name> in the given C<stash>
707 which in the case of success contains an alias for the subroutine, and sets
708 up caching info for this glob.
709
710 The only significant values for C<flags> are C<GV_SUPER>, C<GV_NOUNIVERSAL>, and
711 C<SVf_UTF8>.
712
713 C<GV_SUPER> indicates that we want to look up the method in the superclasses
714 of the C<stash>.
715
716 C<GV_NOUNIVERSAL> indicates that we do not want to look up the method in
717 the stash accessible by C<UNIVERSAL::>.
718
719 The
720 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
721 visible to Perl code. So when calling C<call_sv>, you should not use
722 the GV directly; instead, you should use the method's CV, which can be
723 obtained from the GV with the C<GvCV> macro.
724
725 =for apidoc Amnh||GV_SUPER
726
727 =cut
728 */
729
730 /* NOTE: No support for tied ISA */
731
732 PERL_STATIC_INLINE GV*
S_gv_fetchmeth_internal(pTHX_ HV * stash,SV * meth,const char * name,STRLEN len,I32 level,U32 flags)733 S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, I32 level, U32 flags)
734 {
735 GV** gvp;
736 HE* he;
737 AV* linear_av;
738 SV** linear_svp;
739 SV* linear_sv;
740 HV* cstash, *cachestash;
741 GV* candidate = NULL;
742 CV* cand_cv = NULL;
743 GV* topgv = NULL;
744 const char *hvname;
745 STRLEN hvnamelen;
746 I32 create = (level >= 0) ? HV_FETCH_LVALUE : 0;
747 I32 items;
748 U32 topgen_cmp;
749 U32 is_utf8 = flags & SVf_UTF8;
750
751 /* UNIVERSAL methods should be callable without a stash */
752 if (!stash) {
753 create = 0; /* probably appropriate */
754 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
755 return 0;
756 }
757
758 assert(stash);
759
760 hvname = HvNAME_get(stash);
761 hvnamelen = HvNAMELEN_get(stash);
762 if (!hvname)
763 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
764
765 assert(hvname);
766 assert(name || meth);
767
768 DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
769 flags & GV_SUPER ? "SUPER " : "",
770 name ? name : SvPV_nolen(meth), hvname) );
771
772 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
773
774 if (flags & GV_SUPER) {
775 if (!HvAUX(stash)->xhv_mro_meta->super)
776 HvAUX(stash)->xhv_mro_meta->super = newHV();
777 cachestash = HvAUX(stash)->xhv_mro_meta->super;
778 }
779 else cachestash = stash;
780
781 /* check locally for a real method or a cache entry */
782 he = (HE*)hv_common(
783 cachestash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, create, NULL, 0
784 );
785 if (he) gvp = (GV**)&HeVAL(he);
786 else gvp = NULL;
787
788 if(gvp) {
789 topgv = *gvp;
790 have_gv:
791 assert(topgv);
792 if (SvTYPE(topgv) != SVt_PVGV)
793 {
794 if (!name)
795 name = SvPV_nomg(meth, len);
796 gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
797 }
798 if ((cand_cv = GvCV(topgv))) {
799 /* If genuine method or valid cache entry, use it */
800 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
801 return topgv;
802 }
803 else {
804 /* stale cache entry, junk it and move on */
805 SvREFCNT_dec_NN(cand_cv);
806 GvCV_set(topgv, NULL);
807 cand_cv = NULL;
808 GvCVGEN(topgv) = 0;
809 }
810 }
811 else if (GvCVGEN(topgv) == topgen_cmp) {
812 /* cache indicates no such method definitively */
813 return 0;
814 }
815 else if (stash == cachestash
816 && len > 1 /* shortest is uc */
817 && memEQs(hvname, HvNAMELEN_get(stash), "CORE")
818 && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
819 goto have_gv;
820 }
821
822 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
823 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
824 items = AvFILLp(linear_av); /* no +1, to skip over self */
825 while (items--) {
826 linear_sv = *linear_svp++;
827 assert(linear_sv);
828 cstash = gv_stashsv(linear_sv, 0);
829
830 if (!cstash) {
831 if ( ckWARN(WARN_SYNTAX)) {
832 if( /* these are loaded from Perl_Gv_AMupdate() one way or another */
833 ( len && name[0] == '(' ) /* overload.pm related, in particular "()" */
834 || ( memEQs( name, len, "DESTROY") )
835 ) {
836 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
837 "Can't locate package %" SVf " for @%" HEKf "::ISA",
838 SVfARG(linear_sv),
839 HEKfARG(HvNAME_HEK(stash)));
840
841 } else if( memEQs( name, len, "AUTOLOAD") ) {
842 /* gobble this warning */
843 } else {
844 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
845 "While trying to resolve method call %.*s->%.*s()"
846 " can not locate package \"%" SVf "\" yet it is mentioned in @%.*s::ISA"
847 " (perhaps you forgot to load \"%" SVf "\"?)",
848 (int) hvnamelen, hvname,
849 (int) len, name,
850 SVfARG(linear_sv),
851 (int) hvnamelen, hvname,
852 SVfARG(linear_sv));
853 }
854 }
855 continue;
856 }
857
858 assert(cstash);
859
860 gvp = (GV**)hv_common(
861 cstash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, HV_FETCH_JUST_SV, NULL, 0
862 );
863 if (!gvp) {
864 if (len > 1 && HvNAMELEN_get(cstash) == 4) {
865 const char *hvname = HvNAME(cstash); assert(hvname);
866 if (strBEGINs(hvname, "CORE")
867 && (candidate =
868 S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
869 ))
870 goto have_candidate;
871 }
872 continue;
873 }
874 else candidate = *gvp;
875 have_candidate:
876 assert(candidate);
877 if (SvTYPE(candidate) != SVt_PVGV)
878 gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
879 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
880 /*
881 * Found real method, cache method in topgv if:
882 * 1. topgv has no synonyms (else inheritance crosses wires)
883 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
884 */
885 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
886 CV *old_cv = GvCV(topgv);
887 SvREFCNT_dec(old_cv);
888 SvREFCNT_inc_simple_void_NN(cand_cv);
889 GvCV_set(topgv, cand_cv);
890 GvCVGEN(topgv) = topgen_cmp;
891 }
892 return candidate;
893 }
894 }
895
896 /* Check UNIVERSAL without caching */
897 if((level == 0 || level == -1) && !(flags & GV_NOUNIVERSAL)) {
898 candidate = gv_fetchmeth_internal(NULL, meth, name, len, 1,
899 flags &~GV_SUPER);
900 if(candidate) {
901 cand_cv = GvCV(candidate);
902 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
903 CV *old_cv = GvCV(topgv);
904 SvREFCNT_dec(old_cv);
905 SvREFCNT_inc_simple_void_NN(cand_cv);
906 GvCV_set(topgv, cand_cv);
907 GvCVGEN(topgv) = topgen_cmp;
908 }
909 return candidate;
910 }
911 }
912
913 if (topgv && GvREFCNT(topgv) == 1) {
914 /* cache the fact that the method is not defined */
915 GvCVGEN(topgv) = topgen_cmp;
916 }
917
918 return 0;
919 }
920
921 GV *
Perl_gv_fetchmeth_pvn(pTHX_ HV * stash,const char * name,STRLEN len,I32 level,U32 flags)922 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
923 {
924 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
925 return gv_fetchmeth_internal(stash, NULL, name, len, level, flags);
926 }
927
928 /*
929 =for apidoc gv_fetchmeth_autoload
930
931 This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
932 parameter.
933
934 =for apidoc gv_fetchmeth_sv_autoload
935
936 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
937 of an SV instead of a string/length pair.
938
939 =cut
940 */
941
942 GV *
Perl_gv_fetchmeth_sv_autoload(pTHX_ HV * stash,SV * namesv,I32 level,U32 flags)943 Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
944 {
945 char *namepv;
946 STRLEN namelen;
947 PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
948 namepv = SvPV(namesv, namelen);
949 if (SvUTF8(namesv))
950 flags |= SVf_UTF8;
951 return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
952 }
953
954 /*
955 =for apidoc gv_fetchmeth_pv_autoload
956
957 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
958 instead of a string/length pair.
959
960 =cut
961 */
962
963 GV *
Perl_gv_fetchmeth_pv_autoload(pTHX_ HV * stash,const char * name,I32 level,U32 flags)964 Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
965 {
966 PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
967 return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
968 }
969
970 /*
971 =for apidoc gv_fetchmeth_pvn_autoload
972
973 Same as C<gv_fetchmeth_pvn()>, but looks for autoloaded subroutines too.
974 Returns a glob for the subroutine.
975
976 For an autoloaded subroutine without a GV, will create a GV even
977 if C<level < 0>. For an autoloaded subroutine without a stub, C<GvCV()>
978 of the result may be zero.
979
980 Currently, the only significant value for C<flags> is C<SVf_UTF8>.
981
982 =cut
983 */
984
985 GV *
Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV * stash,const char * name,STRLEN len,I32 level,U32 flags)986 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
987 {
988 GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
989
990 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
991
992 if (!gv) {
993 CV *cv;
994 GV **gvp;
995
996 if (!stash)
997 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
998 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
999 return NULL;
1000 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
1001 return NULL;
1002 cv = GvCV(gv);
1003 if (!(CvROOT(cv) || CvXSUB(cv)))
1004 return NULL;
1005 /* Have an autoload */
1006 if (level < 0) /* Cannot do without a stub */
1007 gv_fetchmeth_pvn(stash, name, len, 0, flags);
1008 gvp = (GV**)hv_fetch(stash, name,
1009 (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
1010 if (!gvp)
1011 return NULL;
1012 return *gvp;
1013 }
1014 return gv;
1015 }
1016
1017 /*
1018 =for apidoc gv_fetchmethod_autoload
1019
1020 Returns the glob which contains the subroutine to call to invoke the method
1021 on the C<stash>. In fact in the presence of autoloading this may be the
1022 glob for "AUTOLOAD". In this case the corresponding variable C<$AUTOLOAD> is
1023 already setup.
1024
1025 The third parameter of C<gv_fetchmethod_autoload> determines whether
1026 AUTOLOAD lookup is performed if the given method is not present: non-zero
1027 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
1028 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
1029 with a non-zero C<autoload> parameter.
1030
1031 These functions grant C<"SUPER"> token
1032 as a prefix of the method name. Note
1033 that if you want to keep the returned glob for a long time, you need to
1034 check for it being "AUTOLOAD", since at the later time the call may load a
1035 different subroutine due to C<$AUTOLOAD> changing its value. Use the glob
1036 created as a side effect to do this.
1037
1038 These functions have the same side-effects as C<gv_fetchmeth> with
1039 C<level==0>. The warning against passing the GV returned by
1040 C<gv_fetchmeth> to C<call_sv> applies equally to these functions.
1041
1042 =cut
1043 */
1044
1045 GV *
Perl_gv_fetchmethod_autoload(pTHX_ HV * stash,const char * name,I32 autoload)1046 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
1047 {
1048 PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
1049
1050 return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
1051 }
1052
1053 GV *
Perl_gv_fetchmethod_sv_flags(pTHX_ HV * stash,SV * namesv,U32 flags)1054 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
1055 {
1056 char *namepv;
1057 STRLEN namelen;
1058 PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
1059 namepv = SvPV(namesv, namelen);
1060 if (SvUTF8(namesv))
1061 flags |= SVf_UTF8;
1062 return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
1063 }
1064
1065 GV *
Perl_gv_fetchmethod_pv_flags(pTHX_ HV * stash,const char * name,U32 flags)1066 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
1067 {
1068 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
1069 return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
1070 }
1071
1072 GV *
Perl_gv_fetchmethod_pvn_flags(pTHX_ HV * stash,const char * name,const STRLEN len,U32 flags)1073 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
1074 {
1075 const char * const origname = name;
1076 const char * const name_end = name + len;
1077 const char *last_separator = NULL;
1078 GV* gv;
1079 HV* ostash = stash;
1080 SV *const error_report = MUTABLE_SV(stash);
1081 const U32 autoload = flags & GV_AUTOLOAD;
1082 const U32 do_croak = flags & GV_CROAK;
1083 const U32 is_utf8 = flags & SVf_UTF8;
1084
1085 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
1086
1087 if (SvTYPE(stash) < SVt_PVHV)
1088 stash = NULL;
1089 else {
1090 /* The only way stash can become NULL later on is if last_separator is set,
1091 which in turn means that there is no need for a SVt_PVHV case
1092 the error reporting code. */
1093 }
1094
1095 {
1096 /* check if the method name is fully qualified or
1097 * not, and separate the package name from the actual
1098 * method name.
1099 *
1100 * leaves last_separator pointing to the beginning of the
1101 * last package separator (either ' or ::) or 0
1102 * if none was found.
1103 *
1104 * leaves name pointing at the beginning of the
1105 * method name.
1106 */
1107 const char *name_cursor = name;
1108 const char * const name_em1 = name_end - 1; /* name_end minus 1 */
1109 for (name_cursor = name; name_cursor < name_end ; name_cursor++) {
1110 if (*name_cursor == '\'') {
1111 last_separator = name_cursor;
1112 name = name_cursor + 1;
1113 }
1114 else if (name_cursor < name_em1 && *name_cursor == ':' && name_cursor[1] == ':') {
1115 last_separator = name_cursor++;
1116 name = name_cursor + 1;
1117 }
1118 }
1119 }
1120
1121 /* did we find a separator? */
1122 if (last_separator) {
1123 STRLEN sep_len= last_separator - origname;
1124 if ( memEQs(origname, sep_len, "SUPER")) {
1125 /* ->SUPER::method should really be looked up in original stash */
1126 stash = CopSTASH(PL_curcop);
1127 flags |= GV_SUPER;
1128 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
1129 origname, HvENAME_get(stash), name) );
1130 }
1131 else if ( sep_len >= 7 &&
1132 strBEGINs(last_separator - 7, "::SUPER")) {
1133 /* don't autovifify if ->NoSuchStash::SUPER::method */
1134 stash = gv_stashpvn(origname, sep_len - 7, is_utf8);
1135 if (stash) flags |= GV_SUPER;
1136 }
1137 else {
1138 /* don't autovifify if ->NoSuchStash::method */
1139 stash = gv_stashpvn(origname, sep_len, is_utf8);
1140 }
1141 ostash = stash;
1142 }
1143
1144 gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
1145 if (!gv) {
1146 /* This is the special case that exempts Foo->import and
1147 Foo->unimport from being an error even if there's no
1148 import/unimport subroutine */
1149 if (strEQ(name,"import") || strEQ(name,"unimport")) {
1150 gv = (GV*)sv_2mortal((SV*)newCONSTSUB_flags(NULL,
1151 NULL, 0, 0, NULL));
1152 } else if (autoload)
1153 gv = gv_autoload_pvn(
1154 ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags
1155 );
1156 if (!gv && do_croak) {
1157 /* Right now this is exclusively for the benefit of S_method_common
1158 in pp_hot.c */
1159 if (stash) {
1160 /* If we can't find an IO::File method, it might be a call on
1161 * a filehandle. If IO:File has not been loaded, try to
1162 * require it first instead of croaking */
1163 const char *stash_name = HvNAME_get(stash);
1164 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1165 && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1166 STR_WITH_LEN("IO/File.pm"), 0,
1167 HV_FETCH_ISEXISTS, NULL, 0)
1168 ) {
1169 require_pv("IO/File.pm");
1170 gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
1171 if (gv)
1172 return gv;
1173 }
1174 Perl_croak(aTHX_
1175 "Can't locate object method \"%" UTF8f
1176 "\" via package \"%" HEKf "\"",
1177 UTF8fARG(is_utf8, name_end - name, name),
1178 HEKfARG(HvNAME_HEK(stash)));
1179 }
1180 else {
1181 SV* packnamesv;
1182
1183 if (last_separator) {
1184 packnamesv = newSVpvn_flags(origname, last_separator - origname,
1185 SVs_TEMP | is_utf8);
1186 } else {
1187 packnamesv = error_report;
1188 }
1189
1190 Perl_croak(aTHX_
1191 "Can't locate object method \"%" UTF8f
1192 "\" via package \"%" SVf "\""
1193 " (perhaps you forgot to load \"%" SVf "\"?)",
1194 UTF8fARG(is_utf8, name_end - name, name),
1195 SVfARG(packnamesv), SVfARG(packnamesv));
1196 }
1197 }
1198 }
1199 else if (autoload) {
1200 CV* const cv = GvCV(gv);
1201 if (!CvROOT(cv) && !CvXSUB(cv)) {
1202 GV* stubgv;
1203 GV* autogv;
1204
1205 if (CvANON(cv) || CvLEXICAL(cv))
1206 stubgv = gv;
1207 else {
1208 stubgv = CvGV(cv);
1209 if (GvCV(stubgv) != cv) /* orphaned import */
1210 stubgv = gv;
1211 }
1212 autogv = gv_autoload_pvn(GvSTASH(stubgv),
1213 GvNAME(stubgv), GvNAMELEN(stubgv),
1214 GV_AUTOLOAD_ISMETHOD
1215 | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1216 if (autogv)
1217 gv = autogv;
1218 }
1219 }
1220
1221 return gv;
1222 }
1223
1224 GV*
Perl_gv_autoload_sv(pTHX_ HV * stash,SV * namesv,U32 flags)1225 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1226 {
1227 char *namepv;
1228 STRLEN namelen;
1229 PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1230 namepv = SvPV(namesv, namelen);
1231 if (SvUTF8(namesv))
1232 flags |= SVf_UTF8;
1233 return gv_autoload_pvn(stash, namepv, namelen, flags);
1234 }
1235
1236 GV*
Perl_gv_autoload_pv(pTHX_ HV * stash,const char * namepv,U32 flags)1237 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1238 {
1239 PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1240 return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1241 }
1242
1243 GV*
Perl_gv_autoload_pvn(pTHX_ HV * stash,const char * name,STRLEN len,U32 flags)1244 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1245 {
1246 GV* gv;
1247 CV* cv;
1248 HV* varstash;
1249 GV* vargv;
1250 SV* varsv;
1251 SV *packname = NULL;
1252 U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1253
1254 PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1255
1256 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1257 return NULL;
1258 if (stash) {
1259 if (SvTYPE(stash) < SVt_PVHV) {
1260 STRLEN packname_len = 0;
1261 const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1262 packname = newSVpvn_flags(packname_ptr, packname_len,
1263 SVs_TEMP | SvUTF8(stash));
1264 stash = NULL;
1265 }
1266 else
1267 packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
1268 if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
1269 }
1270 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE,
1271 is_utf8 | (flags & GV_SUPER))))
1272 return NULL;
1273 cv = GvCV(gv);
1274
1275 if (!(CvROOT(cv) || CvXSUB(cv)))
1276 return NULL;
1277
1278 /*
1279 * Inheriting AUTOLOAD for non-methods no longer works
1280 */
1281 if (
1282 !(flags & GV_AUTOLOAD_ISMETHOD)
1283 && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1284 )
1285 Perl_croak(aTHX_ "Use of inherited AUTOLOAD for non-method %" SVf
1286 "::%" UTF8f "() is no longer allowed",
1287 SVfARG(packname),
1288 UTF8fARG(is_utf8, len, name));
1289
1290 if (CvISXSUB(cv)) {
1291 /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
1292 * and split that value on the last '::', pass along the same data
1293 * via the SvPVX field in the CV, and the stash in CvSTASH.
1294 *
1295 * Due to an unfortunate accident of history, the SvPVX field
1296 * serves two purposes. It is also used for the subroutine's pro-
1297 * type. Since SvPVX has been documented as returning the sub name
1298 * for a long time, but not as returning the prototype, we have
1299 * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
1300 * elsewhere.
1301 *
1302 * We put the prototype in the same allocated buffer, but after
1303 * the sub name. The SvPOK flag indicates the presence of a proto-
1304 * type. The CvAUTOLOAD flag indicates the presence of a sub name.
1305 * If both flags are on, then SvLEN is used to indicate the end of
1306 * the prototype (artificially lower than what is actually allo-
1307 * cated), at the risk of having to reallocate a few bytes unneces-
1308 * sarily--but that should happen very rarely, if ever.
1309 *
1310 * We use SvUTF8 for both prototypes and sub names, so if one is
1311 * UTF8, the other must be upgraded.
1312 */
1313 CvSTASH_set(cv, stash);
1314 if (SvPOK(cv)) { /* Ouch! */
1315 SV * const tmpsv = newSVpvn_flags(name, len, is_utf8);
1316 STRLEN ulen;
1317 const char *proto = CvPROTO(cv);
1318 assert(proto);
1319 if (SvUTF8(cv))
1320 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
1321 ulen = SvCUR(tmpsv);
1322 SvCUR_set(tmpsv, SvCUR(tmpsv) + 1); /* include null in string */
1323 sv_catpvn_flags(
1324 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
1325 );
1326 SvTEMP_on(tmpsv); /* Allow theft */
1327 sv_setsv_nomg((SV *)cv, tmpsv);
1328 SvTEMP_off(tmpsv);
1329 SvREFCNT_dec_NN(tmpsv);
1330 SvLEN_set(cv, SvCUR(cv) + 1);
1331 SvCUR_set(cv, ulen);
1332 }
1333 else {
1334 sv_setpvn((SV *)cv, name, len);
1335 SvPOK_off(cv);
1336 if (is_utf8)
1337 SvUTF8_on(cv);
1338 else SvUTF8_off(cv);
1339 }
1340 CvAUTOLOAD_on(cv);
1341 }
1342
1343 /*
1344 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1345 * The subroutine's original name may not be "AUTOLOAD", so we don't
1346 * use that, but for lack of anything better we will use the sub's
1347 * original package to look up $AUTOLOAD.
1348 */
1349 varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv));
1350 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1351 ENTER;
1352
1353 if (!isGV(vargv)) {
1354 gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1355 #ifdef PERL_DONT_CREATE_GVSV
1356 GvSV(vargv) = newSV(0);
1357 #endif
1358 }
1359 LEAVE;
1360 varsv = GvSVn(vargv);
1361 SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
1362 /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
1363 sv_setsv(varsv, packname);
1364 sv_catpvs(varsv, "::");
1365 /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1366 tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
1367 sv_catpvn_flags(
1368 varsv, name, len,
1369 SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
1370 );
1371 if (is_utf8)
1372 SvUTF8_on(varsv);
1373 return gv;
1374 }
1375
1376
1377 /* require_tie_mod() internal routine for requiring a module
1378 * that implements the logic of automatic ties like %! and %-
1379 * It loads the module and then calls the _tie_it subroutine
1380 * with the passed gv as an argument.
1381 *
1382 * The "gv" parameter should be the glob.
1383 * "varname" holds the 1-char name of the var, used for error messages.
1384 * "namesv" holds the module name. Its refcount will be decremented.
1385 * "flags": if flag & 1 then save the scalar before loading.
1386 * For the protection of $! to work (it is set by this routine)
1387 * the sv slot must already be magicalized.
1388 */
1389 STATIC void
S_require_tie_mod(pTHX_ GV * gv,const char varname,const char * name,STRLEN len,const U32 flags)1390 S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name,
1391 STRLEN len, const U32 flags)
1392 {
1393 const SV * const target = varname == '[' ? GvSV(gv) : (SV *)GvHV(gv);
1394
1395 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1396
1397 /* If it is not tied */
1398 if (!target || !SvRMAGICAL(target)
1399 || !mg_find(target,
1400 varname == '[' ? PERL_MAGIC_tiedscalar : PERL_MAGIC_tied))
1401 {
1402 HV *stash;
1403 GV **gvp;
1404 dSP;
1405
1406 PUSHSTACKi(PERLSI_MAGIC);
1407 ENTER;
1408
1409 #define GET_HV_FETCH_TIE_FUNC \
1410 ( (gvp = (GV **)hv_fetchs(stash, "_tie_it", 0)) \
1411 && *gvp \
1412 && ( (isGV(*gvp) && GvCV(*gvp)) \
1413 || (SvROK(*gvp) && SvTYPE(SvRV(*gvp)) == SVt_PVCV) ) \
1414 )
1415
1416 /* Load the module if it is not loaded. */
1417 if (!(stash = gv_stashpvn(name, len, 0))
1418 || ! GET_HV_FETCH_TIE_FUNC)
1419 {
1420 SV * const module = newSVpvn(name, len);
1421 const char type = varname == '[' ? '$' : '%';
1422 if ( flags & 1 )
1423 save_scalar(gv);
1424 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1425 assert(sp == PL_stack_sp);
1426 stash = gv_stashpvn(name, len, 0);
1427 if (!stash)
1428 Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available",
1429 type, varname, name);
1430 else if (! GET_HV_FETCH_TIE_FUNC)
1431 Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it",
1432 type, varname, name);
1433 }
1434 /* Now call the tie function. It should be in *gvp. */
1435 assert(gvp); assert(*gvp);
1436 PUSHMARK(SP);
1437 XPUSHs((SV *)gv);
1438 PUTBACK;
1439 call_sv((SV *)*gvp, G_VOID|G_DISCARD);
1440 LEAVE;
1441 POPSTACK;
1442 }
1443 }
1444
1445 /* add a require_tie_mod_s - the _s suffix is similar to pvs type suffixes,
1446 * IOW it means we do STR_WITH_LEN() ourselves and the user should pass in
1447 * a true string WITHOUT a len.
1448 */
1449 #define require_tie_mod_s(gv, varname, name, flags) \
1450 S_require_tie_mod(aTHX_ gv, varname, STR_WITH_LEN(name), flags)
1451
1452 /*
1453 =for apidoc gv_stashpv
1454
1455 Returns a pointer to the stash for a specified package. Uses C<strlen> to
1456 determine the length of C<name>, then calls C<gv_stashpvn()>.
1457
1458 =cut
1459 */
1460
1461 HV*
Perl_gv_stashpv(pTHX_ const char * name,I32 create)1462 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1463 {
1464 PERL_ARGS_ASSERT_GV_STASHPV;
1465 return gv_stashpvn(name, strlen(name), create);
1466 }
1467
1468 /*
1469 =for apidoc gv_stashpvn
1470
1471 Returns a pointer to the stash for a specified package. The C<namelen>
1472 parameter indicates the length of the C<name>, in bytes. C<flags> is passed
1473 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1474 created if it does not already exist. If the package does not exist and
1475 C<flags> is 0 (or any other setting that does not create packages) then C<NULL>
1476 is returned.
1477
1478 Flags may be one of:
1479
1480 GV_ADD Create and initialize the package if doesn't
1481 already exist
1482 GV_NOADD_NOINIT Don't create the package,
1483 GV_ADDMG GV_ADD iff the GV is magical
1484 GV_NOINIT GV_ADD, but don't initialize
1485 GV_NOEXPAND Don't expand SvOK() entries to PVGV
1486 SVf_UTF8 The name is in UTF-8
1487
1488 The most important of which are probably C<GV_ADD> and C<SVf_UTF8>.
1489
1490 Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly
1491 recommended for performance reasons.
1492
1493 =for apidoc Amnh||GV_ADD
1494 =for apidoc Amnh||GV_NOADD_NOINIT
1495 =for apidoc Amnh||GV_NOINIT
1496 =for apidoc Amnh||GV_NOEXPAND
1497 =for apidoc Amnh||GV_ADDMG
1498 =for apidoc Amnh||SVf_UTF8
1499
1500 =cut
1501 */
1502
1503 /*
1504 gv_stashpvn_internal
1505
1506 Perform the internal bits of gv_stashsvpvn_cached. You could think of this
1507 as being one half of the logic. Not to be called except from gv_stashsvpvn_cached().
1508
1509 */
1510
1511 PERL_STATIC_INLINE HV*
S_gv_stashpvn_internal(pTHX_ const char * name,U32 namelen,I32 flags)1512 S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags)
1513 {
1514 char smallbuf[128];
1515 char *tmpbuf;
1516 HV *stash;
1517 GV *tmpgv;
1518 U32 tmplen = namelen + 2;
1519
1520 PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL;
1521
1522 if (tmplen <= sizeof smallbuf)
1523 tmpbuf = smallbuf;
1524 else
1525 Newx(tmpbuf, tmplen, char);
1526 Copy(name, tmpbuf, namelen, char);
1527 tmpbuf[namelen] = ':';
1528 tmpbuf[namelen+1] = ':';
1529 tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1530 if (tmpbuf != smallbuf)
1531 Safefree(tmpbuf);
1532 if (!tmpgv || !isGV_with_GP(tmpgv))
1533 return NULL;
1534 stash = GvHV(tmpgv);
1535 if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1536 assert(stash);
1537 if (!HvNAME_get(stash)) {
1538 hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1539
1540 /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1541 /* If the containing stash has multiple effective
1542 names, see that this one gets them, too. */
1543 if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1544 mro_package_moved(stash, NULL, tmpgv, 1);
1545 }
1546 return stash;
1547 }
1548
1549 /*
1550 =for apidoc gv_stashsvpvn_cached
1551
1552 Returns a pointer to the stash for a specified package, possibly
1553 cached. Implements both L<perlapi/C<gv_stashpvn>> and
1554 L<perlapi/C<gv_stashsv>>.
1555
1556 Requires one of either C<namesv> or C<namepv> to be non-null.
1557
1558 If the flag C<GV_CACHE_ONLY> is set, return the stash only if found in the
1559 cache; see L<perlapi/C<gv_stashpvn>> for details on the other C<flags>.
1560
1561 Note it is strongly preferred for C<namesv> to be non-null, for performance
1562 reasons.
1563
1564 =for apidoc Emnh||GV_CACHE_ONLY
1565
1566 =cut
1567 */
1568
1569 #define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \
1570 assert(namesv || name)
1571
1572 HV*
Perl_gv_stashsvpvn_cached(pTHX_ SV * namesv,const char * name,U32 namelen,I32 flags)1573 Perl_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
1574 {
1575 HV* stash;
1576 HE* he;
1577
1578 PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED;
1579
1580 he = (HE *)hv_common(
1581 PL_stashcache, namesv, name, namelen,
1582 (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0
1583 );
1584
1585 if (he) {
1586 SV *sv = HeVAL(he);
1587 HV *hv;
1588 assert(SvIOK(sv));
1589 hv = INT2PTR(HV*, SvIVX(sv));
1590 assert(SvTYPE(hv) == SVt_PVHV);
1591 return hv;
1592 }
1593 else if (flags & GV_CACHE_ONLY) return NULL;
1594
1595 if (namesv) {
1596 if (SvOK(namesv)) { /* prevent double uninit warning */
1597 STRLEN len;
1598 name = SvPV_const(namesv, len);
1599 namelen = len;
1600 flags |= SvUTF8(namesv);
1601 } else {
1602 name = ""; namelen = 0;
1603 }
1604 }
1605 stash = gv_stashpvn_internal(name, namelen, flags);
1606
1607 if (stash && namelen) {
1608 SV* const ref = newSViv(PTR2IV(stash));
1609 (void)hv_store(PL_stashcache, name,
1610 (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0);
1611 }
1612
1613 return stash;
1614 }
1615
1616 HV*
Perl_gv_stashpvn(pTHX_ const char * name,U32 namelen,I32 flags)1617 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1618 {
1619 PERL_ARGS_ASSERT_GV_STASHPVN;
1620 return gv_stashsvpvn_cached(NULL, name, namelen, flags);
1621 }
1622
1623 /*
1624 =for apidoc gv_stashsv
1625
1626 Returns a pointer to the stash for a specified package. See
1627 C<L</gv_stashpvn>>.
1628
1629 Note this interface is strongly preferred over C<gv_stashpvn> for performance
1630 reasons.
1631
1632 =cut
1633 */
1634
1635 HV*
Perl_gv_stashsv(pTHX_ SV * sv,I32 flags)1636 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1637 {
1638 PERL_ARGS_ASSERT_GV_STASHSV;
1639 return gv_stashsvpvn_cached(sv, NULL, 0, flags);
1640 }
1641 GV *
Perl_gv_fetchpv(pTHX_ const char * nambeg,I32 flags,const svtype sv_type)1642 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 flags, const svtype sv_type) {
1643 PERL_ARGS_ASSERT_GV_FETCHPV;
1644 return gv_fetchpvn_flags(nambeg, strlen(nambeg), flags, sv_type);
1645 }
1646
1647 GV *
Perl_gv_fetchsv(pTHX_ SV * name,I32 flags,const svtype sv_type)1648 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1649 STRLEN len;
1650 const char * const nambeg =
1651 SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1652 PERL_ARGS_ASSERT_GV_FETCHSV;
1653 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1654 }
1655
1656 PERL_STATIC_INLINE void
S_gv_magicalize_isa(pTHX_ GV * gv)1657 S_gv_magicalize_isa(pTHX_ GV *gv)
1658 {
1659 AV* av;
1660
1661 PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1662
1663 av = GvAVn(gv);
1664 GvMULTI_on(gv);
1665 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1666 NULL, 0);
1667 }
1668
1669 /* This function grabs name and tries to split a stash and glob
1670 * from its contents. TODO better description, comments
1671 *
1672 * If the function returns TRUE and 'name == name_end', then
1673 * 'gv' can be directly returned to the caller of gv_fetchpvn_flags
1674 */
1675 PERL_STATIC_INLINE bool
S_parse_gv_stash_name(pTHX_ HV ** stash,GV ** gv,const char ** name,STRLEN * len,const char * nambeg,STRLEN full_len,const U32 is_utf8,const I32 add)1676 S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name,
1677 STRLEN *len, const char *nambeg, STRLEN full_len,
1678 const U32 is_utf8, const I32 add)
1679 {
1680 char *tmpfullbuf = NULL; /* only malloc one big chunk of memory when the smallbuff is not large enough */
1681 const char *name_cursor;
1682 const char *const name_end = nambeg + full_len;
1683 const char *const name_em1 = name_end - 1;
1684 char smallbuf[64]; /* small buffer to avoid a malloc when possible */
1685
1686 PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
1687
1688 if ( full_len > 2
1689 && **name == '*'
1690 && isIDFIRST_lazy_if_safe(*name + 1, name_end, is_utf8))
1691 {
1692 /* accidental stringify on a GV? */
1693 (*name)++;
1694 }
1695
1696 for (name_cursor = *name; name_cursor < name_end; name_cursor++) {
1697 if (name_cursor < name_em1 &&
1698 ((*name_cursor == ':' && name_cursor[1] == ':')
1699 || *name_cursor == '\''))
1700 {
1701 if (!*stash)
1702 *stash = PL_defstash;
1703 if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */
1704 goto notok;
1705
1706 *len = name_cursor - *name;
1707 if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1708 const char *key;
1709 GV**gvp;
1710 if (*name_cursor == ':') {
1711 key = *name;
1712 *len += 2;
1713 }
1714 else { /* using ' for package separator */
1715 /* use our pre-allocated buffer when possible to save a malloc */
1716 char *tmpbuf;
1717 if ( *len+2 <= sizeof smallbuf)
1718 tmpbuf = smallbuf;
1719 else {
1720 /* only malloc once if needed */
1721 if (tmpfullbuf == NULL) /* only malloc&free once, a little more than needed */
1722 Newx(tmpfullbuf, full_len+2, char);
1723 tmpbuf = tmpfullbuf;
1724 }
1725 Copy(*name, tmpbuf, *len, char);
1726 tmpbuf[(*len)++] = ':';
1727 tmpbuf[(*len)++] = ':';
1728 key = tmpbuf;
1729 }
1730 gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add);
1731 *gv = gvp ? *gvp : NULL;
1732 if (!*gv || *gv == (const GV *)&PL_sv_undef) {
1733 goto notok;
1734 }
1735 /* here we know that *gv && *gv != &PL_sv_undef */
1736 if (SvTYPE(*gv) != SVt_PVGV)
1737 gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
1738 else
1739 GvMULTI_on(*gv);
1740
1741 if (!(*stash = GvHV(*gv))) {
1742 *stash = GvHV(*gv) = newHV();
1743 if (!HvNAME_get(*stash)) {
1744 if (GvSTASH(*gv) == PL_defstash && *len == 6
1745 && strBEGINs(*name, "CORE"))
1746 hv_name_sets(*stash, "CORE", 0);
1747 else
1748 hv_name_set(
1749 *stash, nambeg, name_cursor-nambeg, is_utf8
1750 );
1751 /* If the containing stash has multiple effective
1752 names, see that this one gets them, too. */
1753 if (HvAUX(GvSTASH(*gv))->xhv_name_count)
1754 mro_package_moved(*stash, NULL, *gv, 1);
1755 }
1756 }
1757 else if (!HvNAME_get(*stash))
1758 hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8);
1759 }
1760
1761 if (*name_cursor == ':')
1762 name_cursor++;
1763 *name = name_cursor+1;
1764 if (*name == name_end) {
1765 if (!*gv) {
1766 *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1767 if (SvTYPE(*gv) != SVt_PVGV) {
1768 gv_init_pvn(*gv, PL_defstash, "main::", 6,
1769 GV_ADDMULTI);
1770 GvHV(*gv) =
1771 MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
1772 }
1773 }
1774 goto ok;
1775 }
1776 }
1777 }
1778 *len = name_cursor - *name;
1779 ok:
1780 Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
1781 return TRUE;
1782 notok:
1783 Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
1784 return FALSE;
1785 }
1786
1787
1788 /* Checks if an unqualified name is in the main stash */
1789 PERL_STATIC_INLINE bool
S_gv_is_in_main(pTHX_ const char * name,STRLEN len,const U32 is_utf8)1790 S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
1791 {
1792 PERL_ARGS_ASSERT_GV_IS_IN_MAIN;
1793
1794 /* If it's an alphanumeric variable */
1795 if ( len && isIDFIRST_lazy_if_safe(name, name + len, is_utf8) ) {
1796 /* Some "normal" variables are always in main::,
1797 * like INC or STDOUT.
1798 */
1799 switch (len) {
1800 case 1:
1801 if (*name == '_')
1802 return TRUE;
1803 break;
1804 case 3:
1805 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1806 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1807 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1808 return TRUE;
1809 break;
1810 case 4:
1811 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1812 && name[3] == 'V')
1813 return TRUE;
1814 break;
1815 case 5:
1816 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1817 && name[3] == 'I' && name[4] == 'N')
1818 return TRUE;
1819 break;
1820 case 6:
1821 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1822 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1823 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1824 return TRUE;
1825 break;
1826 case 7:
1827 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1828 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1829 && name[6] == 'T')
1830 return TRUE;
1831 break;
1832 }
1833 }
1834 /* *{""}, or a special variable like $@ */
1835 else
1836 return TRUE;
1837
1838 return FALSE;
1839 }
1840
1841
1842 /* This function is called if parse_gv_stash_name() failed to
1843 * find a stash, or if GV_NOTQUAL or an empty name was passed
1844 * to gv_fetchpvn_flags.
1845 *
1846 * It returns FALSE if the default stash can't be found nor created,
1847 * which might happen during global destruction.
1848 */
1849 PERL_STATIC_INLINE bool
S_find_default_stash(pTHX_ HV ** stash,const char * name,STRLEN len,const U32 is_utf8,const I32 add,const svtype sv_type)1850 S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
1851 const U32 is_utf8, const I32 add,
1852 const svtype sv_type)
1853 {
1854 PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
1855
1856 /* No stash in name, so see how we can default */
1857
1858 if ( gv_is_in_main(name, len, is_utf8) ) {
1859 *stash = PL_defstash;
1860 }
1861 else {
1862 if (IN_PERL_COMPILETIME) {
1863 *stash = PL_curstash;
1864 if (add && (PL_hints & HINT_STRICT_VARS) &&
1865 sv_type != SVt_PVCV &&
1866 sv_type != SVt_PVGV &&
1867 sv_type != SVt_PVFM &&
1868 sv_type != SVt_PVIO &&
1869 !(len == 1 && sv_type == SVt_PV &&
1870 (*name == 'a' || *name == 'b')) )
1871 {
1872 GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0);
1873 if (!gvp || *gvp == (const GV *)&PL_sv_undef ||
1874 SvTYPE(*gvp) != SVt_PVGV)
1875 {
1876 *stash = NULL;
1877 }
1878 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
1879 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1880 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1881 {
1882 /* diag_listed_as: Variable "%s" is not imported%s */
1883 Perl_ck_warner_d(
1884 aTHX_ packWARN(WARN_MISC),
1885 "Variable \"%c%" UTF8f "\" is not imported",
1886 sv_type == SVt_PVAV ? '@' :
1887 sv_type == SVt_PVHV ? '%' : '$',
1888 UTF8fARG(is_utf8, len, name));
1889 if (GvCVu(*gvp))
1890 Perl_ck_warner_d(
1891 aTHX_ packWARN(WARN_MISC),
1892 "\t(Did you mean &%" UTF8f " instead?)\n",
1893 UTF8fARG(is_utf8, len, name)
1894 );
1895 *stash = NULL;
1896 }
1897 }
1898 }
1899 else {
1900 /* Use the current op's stash */
1901 *stash = CopSTASH(PL_curcop);
1902 }
1903 }
1904
1905 if (!*stash) {
1906 if (add && !PL_in_clean_all) {
1907 GV *gv;
1908 qerror(Perl_mess(aTHX_
1909 "Global symbol \"%s%" UTF8f
1910 "\" requires explicit package name (did you forget to "
1911 "declare \"my %s%" UTF8f "\"?)",
1912 (sv_type == SVt_PV ? "$"
1913 : sv_type == SVt_PVAV ? "@"
1914 : sv_type == SVt_PVHV ? "%"
1915 : ""), UTF8fARG(is_utf8, len, name),
1916 (sv_type == SVt_PV ? "$"
1917 : sv_type == SVt_PVAV ? "@"
1918 : sv_type == SVt_PVHV ? "%"
1919 : ""), UTF8fARG(is_utf8, len, name)));
1920 /* To maintain the output of errors after the strict exception
1921 * above, and to keep compat with older releases, rather than
1922 * placing the variables in the pad, we place
1923 * them in the <none>:: stash.
1924 */
1925 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1926 if (!gv) {
1927 /* symbol table under destruction */
1928 return FALSE;
1929 }
1930 *stash = GvHV(gv);
1931 }
1932 else
1933 return FALSE;
1934 }
1935
1936 if (!SvREFCNT(*stash)) /* symbol table under destruction */
1937 return FALSE;
1938
1939 return TRUE;
1940 }
1941
1942 /* gv_magicalize only turns on the SVf_READONLY flag, not SVf_PROTECT. So
1943 redefine SvREADONLY_on for that purpose. We don’t use it later on in
1944 this file. */
1945 #undef SvREADONLY_on
1946 #define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY)
1947
1948 /* gv_magicalize() is called by gv_fetchpvn_flags when creating
1949 * a new GV.
1950 * Note that it does not insert the GV into the stash prior to
1951 * magicalization, which some variables require need in order
1952 * to work (like %+, %-, %!), so callers must take care of
1953 * that.
1954 *
1955 * It returns true if the gv did turn out to be magical one; i.e.,
1956 * if gv_magicalize actually did something.
1957 */
1958 PERL_STATIC_INLINE bool
S_gv_magicalize(pTHX_ GV * gv,HV * stash,const char * name,STRLEN len,const svtype sv_type)1959 S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
1960 const svtype sv_type)
1961 {
1962 SSize_t paren;
1963
1964 PERL_ARGS_ASSERT_GV_MAGICALIZE;
1965
1966 if (stash != PL_defstash) { /* not the main stash */
1967 /* We only have to check for a few names here: a, b, EXPORT, ISA
1968 and VERSION. All the others apply only to the main stash or to
1969 CORE (which is checked right after this). */
1970 if (len) {
1971 switch (*name) {
1972 case 'E':
1973 if (
1974 len >= 6 && name[1] == 'X' &&
1975 (memEQs(name, len, "EXPORT")
1976 ||memEQs(name, len, "EXPORT_OK")
1977 ||memEQs(name, len, "EXPORT_FAIL")
1978 ||memEQs(name, len, "EXPORT_TAGS"))
1979 )
1980 GvMULTI_on(gv);
1981 break;
1982 case 'I':
1983 if (memEQs(name, len, "ISA"))
1984 gv_magicalize_isa(gv);
1985 break;
1986 case 'V':
1987 if (memEQs(name, len, "VERSION"))
1988 GvMULTI_on(gv);
1989 break;
1990 case 'a':
1991 if (stash == PL_debstash && memEQs(name, len, "args")) {
1992 GvMULTI_on(gv_AVadd(gv));
1993 break;
1994 }
1995 /* FALLTHROUGH */
1996 case 'b':
1997 if (len == 1 && sv_type == SVt_PV)
1998 GvMULTI_on(gv);
1999 /* FALLTHROUGH */
2000 default:
2001 goto try_core;
2002 }
2003 goto ret;
2004 }
2005 try_core:
2006 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
2007 /* Avoid null warning: */
2008 const char * const stashname = HvNAME(stash); assert(stashname);
2009 if (strBEGINs(stashname, "CORE"))
2010 S_maybe_add_coresub(aTHX_ 0, gv, name, len);
2011 }
2012 }
2013 else if (len > 1) {
2014 #ifndef EBCDIC
2015 if (*name > 'V' ) {
2016 NOOP;
2017 /* Nothing else to do.
2018 The compiler will probably turn the switch statement into a
2019 branch table. Make sure we avoid even that small overhead for
2020 the common case of lower case variable names. (On EBCDIC
2021 platforms, we can't just do:
2022 if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) {
2023 because cases like '\027' in the switch statement below are
2024 C1 (non-ASCII) controls on those platforms, so the remapping
2025 would make them larger than 'V')
2026 */
2027 } else
2028 #endif
2029 {
2030 switch (*name) {
2031 case 'A':
2032 if (memEQs(name, len, "ARGV")) {
2033 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
2034 }
2035 else if (memEQs(name, len, "ARGVOUT")) {
2036 GvMULTI_on(gv);
2037 }
2038 break;
2039 case 'E':
2040 if (
2041 len >= 6 && name[1] == 'X' &&
2042 (memEQs(name, len, "EXPORT")
2043 ||memEQs(name, len, "EXPORT_OK")
2044 ||memEQs(name, len, "EXPORT_FAIL")
2045 ||memEQs(name, len, "EXPORT_TAGS"))
2046 )
2047 GvMULTI_on(gv);
2048 break;
2049 case 'I':
2050 if (memEQs(name, len, "ISA")) {
2051 gv_magicalize_isa(gv);
2052 }
2053 break;
2054 case 'S':
2055 if (memEQs(name, len, "SIG")) {
2056 HV *hv;
2057 I32 i;
2058 if (!PL_psig_name) {
2059 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
2060 Newxz(PL_psig_pend, SIG_SIZE, int);
2061 PL_psig_ptr = PL_psig_name + SIG_SIZE;
2062 } else {
2063 /* I think that the only way to get here is to re-use an
2064 embedded perl interpreter, where the previous
2065 use didn't clean up fully because
2066 PL_perl_destruct_level was 0. I'm not sure that we
2067 "support" that, in that I suspect in that scenario
2068 there are sufficient other garbage values left in the
2069 interpreter structure that something else will crash
2070 before we get here. I suspect that this is one of
2071 those "doctor, it hurts when I do this" bugs. */
2072 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
2073 Zero(PL_psig_pend, SIG_SIZE, int);
2074 }
2075 GvMULTI_on(gv);
2076 hv = GvHVn(gv);
2077 hv_magic(hv, NULL, PERL_MAGIC_sig);
2078 for (i = 1; i < SIG_SIZE; i++) {
2079 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
2080 if (init)
2081 sv_setsv(*init, &PL_sv_undef);
2082 }
2083 }
2084 break;
2085 case 'V':
2086 if (memEQs(name, len, "VERSION"))
2087 GvMULTI_on(gv);
2088 break;
2089 case '\003': /* $^CHILD_ERROR_NATIVE */
2090 if (memEQs(name, len, "\003HILD_ERROR_NATIVE"))
2091 goto magicalize;
2092 /* @{^CAPTURE} %{^CAPTURE} */
2093 if (memEQs(name, len, "\003APTURE")) {
2094 AV* const av = GvAVn(gv);
2095 const Size_t n = *name;
2096
2097 sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
2098 SvREADONLY_on(av);
2099
2100 require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
2101
2102 } else /* %{^CAPTURE_ALL} */
2103 if (memEQs(name, len, "\003APTURE_ALL")) {
2104 require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
2105 }
2106 break;
2107 case '\005': /* $^ENCODING */
2108 if (memEQs(name, len, "\005NCODING"))
2109 goto magicalize;
2110 break;
2111 case '\007': /* $^GLOBAL_PHASE */
2112 if (memEQs(name, len, "\007LOBAL_PHASE"))
2113 goto ro_magicalize;
2114 break;
2115 case '\014': /* $^LAST_FH */
2116 if (memEQs(name, len, "\014AST_FH"))
2117 goto ro_magicalize;
2118 break;
2119 case '\015': /* $^MATCH */
2120 if (memEQs(name, len, "\015ATCH")) {
2121 paren = RX_BUFF_IDX_CARET_FULLMATCH;
2122 goto storeparen;
2123 }
2124 break;
2125 case '\017': /* $^OPEN */
2126 if (memEQs(name, len, "\017PEN"))
2127 goto magicalize;
2128 break;
2129 case '\020': /* $^PREMATCH $^POSTMATCH */
2130 if (memEQs(name, len, "\020REMATCH")) {
2131 paren = RX_BUFF_IDX_CARET_PREMATCH;
2132 goto storeparen;
2133 }
2134 if (memEQs(name, len, "\020OSTMATCH")) {
2135 paren = RX_BUFF_IDX_CARET_POSTMATCH;
2136 goto storeparen;
2137 }
2138 break;
2139 case '\023':
2140 if (memEQs(name, len, "\023AFE_LOCALES"))
2141 goto ro_magicalize;
2142 break;
2143 case '\024': /* ${^TAINT} */
2144 if (memEQs(name, len, "\024AINT"))
2145 goto ro_magicalize;
2146 break;
2147 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
2148 if (memEQs(name, len, "\025NICODE"))
2149 goto ro_magicalize;
2150 if (memEQs(name, len, "\025TF8LOCALE"))
2151 goto ro_magicalize;
2152 if (memEQs(name, len, "\025TF8CACHE"))
2153 goto magicalize;
2154 break;
2155 case '\027': /* $^WARNING_BITS */
2156 if (memEQs(name, len, "\027ARNING_BITS"))
2157 goto magicalize;
2158 #ifdef WIN32
2159 else if (memEQs(name, len, "\027IN32_SLOPPY_STAT"))
2160 goto magicalize;
2161 #endif
2162 break;
2163 case '1':
2164 case '2':
2165 case '3':
2166 case '4':
2167 case '5':
2168 case '6':
2169 case '7':
2170 case '8':
2171 case '9':
2172 {
2173 /* Ensures that we have an all-digit variable, ${"1foo"} fails
2174 this test */
2175 UV uv;
2176 if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX)
2177 goto ret;
2178 /* XXX why are we using a SSize_t? */
2179 paren = (SSize_t)(I32)uv;
2180 goto storeparen;
2181 }
2182 }
2183 }
2184 } else {
2185 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
2186 be case '\0' in this switch statement (ie a default case) */
2187 switch (*name) {
2188 case '&': /* $& */
2189 paren = RX_BUFF_IDX_FULLMATCH;
2190 goto sawampersand;
2191 case '`': /* $` */
2192 paren = RX_BUFF_IDX_PREMATCH;
2193 goto sawampersand;
2194 case '\'': /* $' */
2195 paren = RX_BUFF_IDX_POSTMATCH;
2196 sawampersand:
2197 #ifdef PERL_SAWAMPERSAND
2198 if (!(
2199 sv_type == SVt_PVAV ||
2200 sv_type == SVt_PVHV ||
2201 sv_type == SVt_PVCV ||
2202 sv_type == SVt_PVFM ||
2203 sv_type == SVt_PVIO
2204 )) { PL_sawampersand |=
2205 (*name == '`')
2206 ? SAWAMPERSAND_LEFT
2207 : (*name == '&')
2208 ? SAWAMPERSAND_MIDDLE
2209 : SAWAMPERSAND_RIGHT;
2210 }
2211 #endif
2212 goto storeparen;
2213 case '1': /* $1 */
2214 case '2': /* $2 */
2215 case '3': /* $3 */
2216 case '4': /* $4 */
2217 case '5': /* $5 */
2218 case '6': /* $6 */
2219 case '7': /* $7 */
2220 case '8': /* $8 */
2221 case '9': /* $9 */
2222 paren = *name - '0';
2223
2224 storeparen:
2225 /* Flag the capture variables with a NULL mg_ptr
2226 Use mg_len for the array index to lookup. */
2227 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
2228 break;
2229
2230 case ':': /* $: */
2231 sv_setpv(GvSVn(gv),PL_chopset);
2232 goto magicalize;
2233
2234 case '?': /* $? */
2235 #ifdef COMPLEX_STATUS
2236 SvUPGRADE(GvSVn(gv), SVt_PVLV);
2237 #endif
2238 goto magicalize;
2239
2240 case '!': /* $! */
2241 GvMULTI_on(gv);
2242 /* If %! has been used, automatically load Errno.pm. */
2243
2244 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2245
2246 /* magicalization must be done before require_tie_mod_s is called */
2247 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2248 require_tie_mod_s(gv, '!', "Errno", 1);
2249
2250 break;
2251 case '-': /* $-, %-, @- */
2252 case '+': /* $+, %+, @+ */
2253 GvMULTI_on(gv); /* no used once warnings here */
2254 { /* $- $+ */
2255 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2256 if (*name == '+')
2257 SvREADONLY_on(GvSVn(gv));
2258 }
2259 { /* %- %+ */
2260 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2261 require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture",0);
2262 }
2263 { /* @- @+ */
2264 AV* const av = GvAVn(gv);
2265 const Size_t n = *name;
2266
2267 sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
2268 SvREADONLY_on(av);
2269 }
2270 break;
2271 case '*': /* $* */
2272 case '#': /* $# */
2273 if (sv_type == SVt_PV)
2274 /* diag_listed_as: $* is no longer supported as of Perl 5.30 */
2275 Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name);
2276 break;
2277 case '\010': /* $^H */
2278 {
2279 HV *const hv = GvHVn(gv);
2280 hv_magic(hv, NULL, PERL_MAGIC_hints);
2281 }
2282 goto magicalize;
2283 case '\023': /* $^S */
2284 ro_magicalize:
2285 SvREADONLY_on(GvSVn(gv));
2286 /* FALLTHROUGH */
2287 case '0': /* $0 */
2288 case '^': /* $^ */
2289 case '~': /* $~ */
2290 case '=': /* $= */
2291 case '%': /* $% */
2292 case '.': /* $. */
2293 case '(': /* $( */
2294 case ')': /* $) */
2295 case '<': /* $< */
2296 case '>': /* $> */
2297 case '\\': /* $\ */
2298 case '/': /* $/ */
2299 case '|': /* $| */
2300 case '$': /* $$ */
2301 case '[': /* $[ */
2302 case '\001': /* $^A */
2303 case '\003': /* $^C */
2304 case '\004': /* $^D */
2305 case '\005': /* $^E */
2306 case '\006': /* $^F */
2307 case '\011': /* $^I, NOT \t in EBCDIC */
2308 case '\016': /* $^N */
2309 case '\017': /* $^O */
2310 case '\020': /* $^P */
2311 case '\024': /* $^T */
2312 case '\027': /* $^W */
2313 magicalize:
2314 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2315 break;
2316
2317 case '\014': /* $^L */
2318 sv_setpvs(GvSVn(gv),"\f");
2319 break;
2320 case ';': /* $; */
2321 sv_setpvs(GvSVn(gv),"\034");
2322 break;
2323 case ']': /* $] */
2324 {
2325 SV * const sv = GvSV(gv);
2326 if (!sv_derived_from(PL_patchlevel, "version"))
2327 upg_version(PL_patchlevel, TRUE);
2328 GvSV(gv) = vnumify(PL_patchlevel);
2329 SvREADONLY_on(GvSV(gv));
2330 SvREFCNT_dec(sv);
2331 }
2332 break;
2333 case '\026': /* $^V */
2334 {
2335 SV * const sv = GvSV(gv);
2336 GvSV(gv) = new_version(PL_patchlevel);
2337 SvREADONLY_on(GvSV(gv));
2338 SvREFCNT_dec(sv);
2339 }
2340 break;
2341 case 'a':
2342 case 'b':
2343 if (sv_type == SVt_PV)
2344 GvMULTI_on(gv);
2345 }
2346 }
2347
2348 ret:
2349 /* Return true if we actually did something. */
2350 return GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv)
2351 || ( GvSV(gv) && (
2352 SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv))
2353 )
2354 );
2355 }
2356
2357 /* If we do ever start using this later on in the file, we need to make
2358 sure we don’t accidentally use the wrong definition. */
2359 #undef SvREADONLY_on
2360
2361 /* This function is called when the stash already holds the GV of the magic
2362 * variable we're looking for, but we need to check that it has the correct
2363 * kind of magic. For example, if someone first uses $! and then %!, the
2364 * latter would end up here, and we add the Errno tie to the HASH slot of
2365 * the *! glob.
2366 */
2367 PERL_STATIC_INLINE void
S_maybe_multimagic_gv(pTHX_ GV * gv,const char * name,const svtype sv_type)2368 S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
2369 {
2370 PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV;
2371
2372 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
2373 if (*name == '!')
2374 require_tie_mod_s(gv, '!', "Errno", 1);
2375 else if (*name == '-' || *name == '+')
2376 require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture", 0);
2377 } else if (sv_type == SVt_PV) {
2378 if (*name == '*' || *name == '#') {
2379 /* diag_listed_as: $* is no longer supported as of Perl 5.30 */
2380 Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name);
2381 }
2382 }
2383 if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
2384 switch (*name) {
2385 #ifdef PERL_SAWAMPERSAND
2386 case '`':
2387 PL_sawampersand |= SAWAMPERSAND_LEFT;
2388 (void)GvSVn(gv);
2389 break;
2390 case '&':
2391 PL_sawampersand |= SAWAMPERSAND_MIDDLE;
2392 (void)GvSVn(gv);
2393 break;
2394 case '\'':
2395 PL_sawampersand |= SAWAMPERSAND_RIGHT;
2396 (void)GvSVn(gv);
2397 break;
2398 #endif
2399 }
2400 }
2401 }
2402
2403 /*
2404 =for apidoc gv_fetchpv
2405 =for apidoc_item |GV *|gv_fetchpvn|const char * nambeg|STRLEN full_len|I32 flags|const svtype sv_type
2406 =for apidoc_item ||gv_fetchpvn_flags
2407 =for apidoc_item |GV *|gv_fetchpvs|"name"|I32 flags|const svtype sv_type
2408 =for apidoc_item ||gv_fetchsv
2409 =for apidoc_item |GV *|gv_fetchsv_nomg|SV *name|I32 flags|const svtype sv_type
2410
2411 These all return the GV of type C<sv_type> whose name is given by the inputs,
2412 or NULL if no GV of that name and type could be found. See L<perlguts/Stashes
2413 and Globs>.
2414
2415 The only differences are how the input name is specified, and if 'get' magic is
2416 normally used in getting that name.
2417
2418 Don't be fooled by the fact that only one form has C<flags> in its name. They
2419 all have a C<flags> parameter in fact, and all the flag bits have the same
2420 meanings for all
2421
2422 If any of the flags C<GV_ADD>, C<GV_ADDMG>, C<GV_ADDWARN>, C<GV_ADDMULTI>, or
2423 C<GV_NOINIT> is set, a GV is created if none already exists for the input name
2424 and type. However, C<GV_ADDMG> will only do the creation for magical GV's.
2425 For all of these flags except C<GV_NOINIT>, C<L</gv_init_pvn>> is called after
2426 the addition. C<GV_ADDWARN> is used when the caller expects that adding won't
2427 be necessary because the symbol should already exist; but if not, add it
2428 anyway, with a warning that it was unexpectedly absent. The C<GV_ADDMULTI>
2429 flag means to pretend that the GV has been seen before (I<i.e.>, suppress "Used
2430 once" warnings).
2431
2432 The flag C<GV_NOADD_NOINIT> causes C<L</gv_init_pvn>> not be to called if the
2433 GV existed but isn't PVGV.
2434
2435 If the C<SVf_UTF8> bit is set, the name is treated as being encoded in UTF-8;
2436 otherwise the name won't be considered to be UTF-8 in the C<pv>-named forms,
2437 and the UTF-8ness of the underlying SVs will be used in the C<sv> forms.
2438
2439 If the flag C<GV_NOTQUAL> is set, the caller warrants that the input name is a
2440 plain symbol name, not qualified with a package, otherwise the name is checked
2441 for being a qualified one.
2442
2443 In C<gv_fetchpv>, C<nambeg> is a C string, NUL-terminated with no intermediate
2444 NULs.
2445
2446 In C<gv_fetchpvs>, C<name> is a literal C string, hence is enclosed in
2447 double quotes.
2448
2449 C<gv_fetchpvn> and C<gv_fetchpvn_flags> are identical. In these, <nambeg> is
2450 a Perl string whose byte length is given by C<full_len>, and may contain
2451 embedded NULs.
2452
2453 In C<gv_fetchsv> and C<gv_fetchsv_nomg>, the name is extracted from the PV of
2454 the input C<name> SV. The only difference between these two forms is that
2455 'get' magic is normally done on C<name> in C<gv_fetchsv>, and always skipped
2456 with C<gv_fetchsv_nomg>. Including C<GV_NO_SVGMAGIC> in the C<flags> parameter
2457 to C<gv_fetchsv> makes it behave identically to C<gv_fetchsv_nomg>.
2458
2459 =for apidoc Amnh||GV_ADD
2460 =for apidoc Amnh||GV_ADDMG
2461 =for apidoc Amnh||GV_ADDMULTI
2462 =for apidoc Amnh||GV_ADDWARN
2463 =for apidoc Amnh||GV_NOADD_NOINIT
2464 =for apidoc Amnh||GV_NOINIT
2465 =for apidoc Amnh||GV_NOTQUAL
2466 =for apidoc Amnh||GV_NO_SVGMAGIC
2467 =for apidoc Amnh||SVf_UTF8
2468
2469 =cut
2470 */
2471
2472 GV *
Perl_gv_fetchpvn_flags(pTHX_ const char * nambeg,STRLEN full_len,I32 flags,const svtype sv_type)2473 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
2474 const svtype sv_type)
2475 {
2476 const char *name = nambeg;
2477 GV *gv = NULL;
2478 GV**gvp;
2479 STRLEN len;
2480 HV *stash = NULL;
2481 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
2482 const I32 no_expand = flags & GV_NOEXPAND;
2483 const I32 add = flags & ~GV_NOADD_MASK;
2484 const U32 is_utf8 = flags & SVf_UTF8;
2485 bool addmg = cBOOL(flags & GV_ADDMG);
2486 const char *const name_end = nambeg + full_len;
2487 U32 faking_it;
2488
2489 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
2490
2491 /* If we have GV_NOTQUAL, the caller promised that
2492 * there is no stash, so we can skip the check.
2493 * Similarly if full_len is 0, since then we're
2494 * dealing with something like *{""} or ""->foo()
2495 */
2496 if ((flags & GV_NOTQUAL) || !full_len) {
2497 len = full_len;
2498 }
2499 else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) {
2500 if (name == name_end) return gv;
2501 }
2502 else {
2503 return NULL;
2504 }
2505
2506 if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) {
2507 return NULL;
2508 }
2509
2510 /* By this point we should have a stash and a name */
2511 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add);
2512 if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
2513 if (addmg) gv = (GV *)newSV(0); /* tentatively */
2514 else return NULL;
2515 }
2516 else gv = *gvp, addmg = 0;
2517 /* From this point on, addmg means gv has not been inserted in the
2518 symtab yet. */
2519
2520 if (SvTYPE(gv) == SVt_PVGV) {
2521 /* The GV already exists, so return it, but check if we need to do
2522 * anything else with it before that.
2523 */
2524 if (add) {
2525 /* This is the heuristic that handles if a variable triggers the
2526 * 'used only once' warning. If there's already a GV in the stash
2527 * with this name, then we assume that the variable has been used
2528 * before and turn its MULTI flag on.
2529 * It's a heuristic because it can easily be "tricked", like with
2530 * BEGIN { $a = 1; $::{foo} = *a }; () = $foo
2531 * not warning about $main::foo being used just once
2532 */
2533 GvMULTI_on(gv);
2534 gv_init_svtype(gv, sv_type);
2535 /* You reach this path once the typeglob has already been created,
2536 either by the same or a different sigil. If this path didn't
2537 exist, then (say) referencing $! first, and %! second would
2538 mean that %! was not handled correctly. */
2539 if (len == 1 && stash == PL_defstash) {
2540 maybe_multimagic_gv(gv, name, sv_type);
2541 }
2542 else if (sv_type == SVt_PVAV
2543 && memEQs(name, len, "ISA")
2544 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
2545 gv_magicalize_isa(gv);
2546 }
2547 return gv;
2548 } else if (no_init) {
2549 assert(!addmg);
2550 return gv;
2551 }
2552 /* If GV_NOEXPAND is true and what we got off the stash is a ref,
2553 * don't expand it to a glob. This is an optimization so that things
2554 * copying constants over, like Exporter, don't have to be rewritten
2555 * to take into account that you can store more than just globs in
2556 * stashes.
2557 */
2558 else if (no_expand && SvROK(gv)) {
2559 assert(!addmg);
2560 return gv;
2561 }
2562
2563 /* Adding a new symbol.
2564 Unless of course there was already something non-GV here, in which case
2565 we want to behave as if there was always a GV here, containing some sort
2566 of subroutine.
2567 Otherwise we run the risk of creating things like GvIO, which can cause
2568 subtle bugs. eg the one that tripped up SQL::Translator */
2569
2570 faking_it = SvOK(gv);
2571
2572 if (add & GV_ADDWARN)
2573 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2574 "Had to create %" UTF8f " unexpectedly",
2575 UTF8fARG(is_utf8, name_end-nambeg, nambeg));
2576 gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
2577
2578 if ( full_len != 0
2579 && isIDFIRST_lazy_if_safe(name, name + full_len, is_utf8)
2580 && !ckWARN(WARN_ONCE) )
2581 {
2582 GvMULTI_on(gv) ;
2583 }
2584
2585 /* set up magic where warranted */
2586 if ( gv_magicalize(gv, stash, name, len, sv_type) ) {
2587 /* See 23496c6 */
2588 if (addmg) {
2589 /* gv_magicalize magicalised this gv, so we want it
2590 * stored in the symtab.
2591 * Effectively the caller is asking, ‘Does this gv exist?’
2592 * And we respond, ‘Er, *now* it does!’
2593 */
2594 (void)hv_store(stash,name,len,(SV *)gv,0);
2595 }
2596 }
2597 else if (addmg) {
2598 /* The temporary GV created above */
2599 SvREFCNT_dec_NN(gv);
2600 gv = NULL;
2601 }
2602
2603 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2604 return gv;
2605 }
2606
2607 void
Perl_gv_fullname4(pTHX_ SV * sv,const GV * gv,const char * prefix,bool keepmain)2608 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2609 {
2610 const char *name;
2611 const HV * const hv = GvSTASH(gv);
2612
2613 PERL_ARGS_ASSERT_GV_FULLNAME4;
2614
2615 sv_setpv(sv, prefix ? prefix : "");
2616
2617 if (hv && (name = HvNAME(hv))) {
2618 const STRLEN len = HvNAMELEN(hv);
2619 if (keepmain || ! memBEGINs(name, len, "main")) {
2620 sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2621 sv_catpvs(sv,"::");
2622 }
2623 }
2624 else sv_catpvs(sv,"__ANON__::");
2625 sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2626 }
2627
2628 void
Perl_gv_efullname4(pTHX_ SV * sv,const GV * gv,const char * prefix,bool keepmain)2629 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2630 {
2631 const GV * const egv = GvEGVx(gv);
2632
2633 PERL_ARGS_ASSERT_GV_EFULLNAME4;
2634
2635 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2636 }
2637
2638
2639 /* recursively scan a stash and any nested stashes looking for entries
2640 * that need the "only used once" warning raised
2641 */
2642
2643 void
Perl_gv_check(pTHX_ HV * stash)2644 Perl_gv_check(pTHX_ HV *stash)
2645 {
2646 I32 i;
2647
2648 PERL_ARGS_ASSERT_GV_CHECK;
2649
2650 if (!SvOOK(stash))
2651 return;
2652
2653 assert(HvARRAY(stash));
2654
2655 /* mark stash is being scanned, to avoid recursing */
2656 HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH;
2657 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2658 const HE *entry;
2659 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2660 GV *gv;
2661 HV *hv;
2662 STRLEN keylen = HeKLEN(entry);
2663 const char * const key = HeKEY(entry);
2664
2665 if (keylen >= 2 && key[keylen-2] == ':' && key[keylen-1] == ':' &&
2666 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2667 {
2668 if (hv != PL_defstash && hv != stash
2669 && !(SvOOK(hv)
2670 && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH))
2671 )
2672 gv_check(hv); /* nested package */
2673 }
2674 else if ( HeKLEN(entry) != 0
2675 && *HeKEY(entry) != '_'
2676 && isIDFIRST_lazy_if_safe(HeKEY(entry),
2677 HeKEY(entry) + HeKLEN(entry),
2678 HeUTF8(entry)) )
2679 {
2680 const char *file;
2681 gv = MUTABLE_GV(HeVAL(entry));
2682 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2683 continue;
2684 file = GvFILE(gv);
2685 CopLINE_set(PL_curcop, GvLINE(gv));
2686 #ifdef USE_ITHREADS
2687 CopFILE(PL_curcop) = (char *)file; /* set for warning */
2688 #else
2689 CopFILEGV(PL_curcop)
2690 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2691 #endif
2692 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2693 "Name \"%" HEKf "::%" HEKf
2694 "\" used only once: possible typo",
2695 HEKfARG(HvNAME_HEK(stash)),
2696 HEKfARG(GvNAME_HEK(gv)));
2697 }
2698 }
2699 }
2700 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH;
2701 }
2702
2703 GV *
Perl_newGVgen_flags(pTHX_ const char * pack,U32 flags)2704 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2705 {
2706 PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2707 assert(!(flags & ~SVf_UTF8));
2708
2709 return gv_fetchpv(Perl_form(aTHX_ "%" UTF8f "::_GEN_%ld",
2710 UTF8fARG(flags, strlen(pack), pack),
2711 (long)PL_gensym++),
2712 GV_ADD, SVt_PVGV);
2713 }
2714
2715 /* hopefully this is only called on local symbol table entries */
2716
2717 GP*
Perl_gp_ref(pTHX_ GP * gp)2718 Perl_gp_ref(pTHX_ GP *gp)
2719 {
2720 if (!gp)
2721 return NULL;
2722 gp->gp_refcnt++;
2723 if (gp->gp_cv) {
2724 if (gp->gp_cvgen) {
2725 /* If the GP they asked for a reference to contains
2726 a method cache entry, clear it first, so that we
2727 don't infect them with our cached entry */
2728 SvREFCNT_dec_NN(gp->gp_cv);
2729 gp->gp_cv = NULL;
2730 gp->gp_cvgen = 0;
2731 }
2732 }
2733 return gp;
2734 }
2735
2736 void
Perl_gp_free(pTHX_ GV * gv)2737 Perl_gp_free(pTHX_ GV *gv)
2738 {
2739 GP* gp;
2740 int attempts = 100;
2741 bool in_global_destruction = PL_phase == PERL_PHASE_DESTRUCT;
2742
2743 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2744 return;
2745 if (gp->gp_refcnt == 0) {
2746 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2747 "Attempt to free unreferenced glob pointers"
2748 pTHX__FORMAT pTHX__VALUE);
2749 return;
2750 }
2751 if (gp->gp_refcnt > 1) {
2752 borrowed:
2753 if (gp->gp_egv == gv)
2754 gp->gp_egv = 0;
2755 gp->gp_refcnt--;
2756 GvGP_set(gv, NULL);
2757 return;
2758 }
2759
2760 while (1) {
2761 /* Copy and null out all the glob slots, so destructors do not see
2762 freed SVs. */
2763 HEK * const file_hek = gp->gp_file_hek;
2764 SV * sv = gp->gp_sv;
2765 AV * av = gp->gp_av;
2766 HV * hv = gp->gp_hv;
2767 IO * io = gp->gp_io;
2768 CV * cv = gp->gp_cv;
2769 CV * form = gp->gp_form;
2770
2771 int need = 0;
2772
2773 gp->gp_file_hek = NULL;
2774 gp->gp_sv = NULL;
2775 gp->gp_av = NULL;
2776 gp->gp_hv = NULL;
2777 gp->gp_io = NULL;
2778 gp->gp_cv = NULL;
2779 gp->gp_form = NULL;
2780
2781 if (file_hek)
2782 unshare_hek(file_hek);
2783
2784 /* Storing the SV on the temps stack (instead of freeing it immediately)
2785 is an admitted bodge that attempt to compensate for the lack of
2786 reference counting on the stack. The motivation is that typeglob syntax
2787 is extremely short hence programs such as '$a += (*a = 2)' are often
2788 found randomly by researchers running fuzzers. Previously these
2789 programs would trigger errors, that the researchers would
2790 (legitimately) report, and then we would spend time figuring out that
2791 the cause was "stack not reference counted" and so not a dangerous
2792 security hole. This consumed a lot of researcher time, our time, and
2793 prevents "interesting" security holes being uncovered.
2794
2795 Typeglob assignment is rarely used in performance critical production
2796 code, so we aren't causing much slowdown by doing extra work here.
2797
2798 In turn, the need to check for SvOBJECT (and references to objects) is
2799 because we have regression tests that rely on timely destruction that
2800 happens *within this while loop* to demonstrate behaviour, and
2801 potentially there is also *working* code in the wild that relies on
2802 such behaviour.
2803
2804 And we need to avoid doing this in global destruction else we can end
2805 up with "Attempt to free temp prematurely ... Unbalanced string table
2806 refcount".
2807
2808 Hence the whole thing is a heuristic intended to mitigate against
2809 simple problems likely found by fuzzers but never written by humans,
2810 whilst leaving working code unchanged. */
2811 if (sv) {
2812 SV *referant;
2813 if (SvREFCNT(sv) > 1 || SvOBJECT(sv) || UNLIKELY(in_global_destruction)) {
2814 SvREFCNT_dec_NN(sv);
2815 sv = NULL;
2816 } else if (SvROK(sv) && (referant = SvRV(sv))
2817 && (SvREFCNT(referant) > 1 || SvOBJECT(referant))) {
2818 SvREFCNT_dec_NN(sv);
2819 sv = NULL;
2820 } else {
2821 ++need;
2822 }
2823 }
2824 if (av) {
2825 if (SvREFCNT(av) > 1 || SvOBJECT(av) || UNLIKELY(in_global_destruction)) {
2826 SvREFCNT_dec_NN(av);
2827 av = NULL;
2828 } else {
2829 ++need;
2830 }
2831 }
2832 /* FIXME - another reference loop GV -> symtab -> GV ?
2833 Somehow gp->gp_hv can end up pointing at freed garbage. */
2834 if (hv && SvTYPE(hv) == SVt_PVHV) {
2835 const HEK *hvname_hek = HvNAME_HEK(hv);
2836 if (PL_stashcache && hvname_hek) {
2837 DEBUG_o(Perl_deb(aTHX_
2838 "gp_free clearing PL_stashcache for '%" HEKf "'\n",
2839 HEKfARG(hvname_hek)));
2840 (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
2841 }
2842 if (SvREFCNT(hv) > 1 || SvOBJECT(hv) || UNLIKELY(in_global_destruction)) {
2843 SvREFCNT_dec_NN(hv);
2844 hv = NULL;
2845 } else {
2846 ++need;
2847 }
2848 }
2849 if (io && SvREFCNT(io) == 1 && IoIFP(io)
2850 && (IoTYPE(io) == IoTYPE_WRONLY ||
2851 IoTYPE(io) == IoTYPE_RDWR ||
2852 IoTYPE(io) == IoTYPE_APPEND)
2853 && ckWARN_d(WARN_IO)
2854 && IoIFP(io) != PerlIO_stdin()
2855 && IoIFP(io) != PerlIO_stdout()
2856 && IoIFP(io) != PerlIO_stderr()
2857 && !(IoFLAGS(io) & IOf_FAKE_DIRP))
2858 io_close(io, gv, FALSE, TRUE);
2859 if (io) {
2860 if (SvREFCNT(io) > 1 || SvOBJECT(io) || UNLIKELY(in_global_destruction)) {
2861 SvREFCNT_dec_NN(io);
2862 io = NULL;
2863 } else {
2864 ++need;
2865 }
2866 }
2867 if (cv) {
2868 if (SvREFCNT(cv) > 1 || SvOBJECT(cv) || UNLIKELY(in_global_destruction)) {
2869 SvREFCNT_dec_NN(cv);
2870 cv = NULL;
2871 } else {
2872 ++need;
2873 }
2874 }
2875 if (form) {
2876 if (SvREFCNT(form) > 1 || SvOBJECT(form) || UNLIKELY(in_global_destruction)) {
2877 SvREFCNT_dec_NN(form);
2878 form = NULL;
2879 } else {
2880 ++need;
2881 }
2882 }
2883
2884 if (need) {
2885 /* We don't strictly need to defer all this to the end, but it's
2886 easiest to do so. The subtle problems we have are
2887 1) any of the actions triggered by the various SvREFCNT_dec()s in
2888 any of the intermediate blocks can cause more items to be added
2889 to the temps stack. So we can't "cache" its state locally
2890 2) We'd have to re-check the "extend by 1?" for each time.
2891 Whereas if we don't NULL out the values that we want to put onto
2892 the save stack until here, we can do it in one go, with one
2893 one size check. */
2894
2895 SSize_t max_ix = PL_tmps_ix + need;
2896
2897 if (max_ix >= PL_tmps_max) {
2898 tmps_grow_p(max_ix);
2899 }
2900
2901 if (sv) {
2902 PL_tmps_stack[++PL_tmps_ix] = sv;
2903 }
2904 if (av) {
2905 PL_tmps_stack[++PL_tmps_ix] = (SV *) av;
2906 }
2907 if (hv) {
2908 PL_tmps_stack[++PL_tmps_ix] = (SV *) hv;
2909 }
2910 if (io) {
2911 PL_tmps_stack[++PL_tmps_ix] = (SV *) io;
2912 }
2913 if (cv) {
2914 PL_tmps_stack[++PL_tmps_ix] = (SV *) cv;
2915 }
2916 if (form) {
2917 PL_tmps_stack[++PL_tmps_ix] = (SV *) form;
2918 }
2919 }
2920
2921 /* Possibly reallocated by a destructor */
2922 gp = GvGP(gv);
2923
2924 if (!gp->gp_file_hek
2925 && !gp->gp_sv
2926 && !gp->gp_av
2927 && !gp->gp_hv
2928 && !gp->gp_io
2929 && !gp->gp_cv
2930 && !gp->gp_form) break;
2931
2932 if (--attempts == 0) {
2933 Perl_die(aTHX_
2934 "panic: gp_free failed to free glob pointer - "
2935 "something is repeatedly re-creating entries"
2936 );
2937 }
2938 }
2939
2940 /* Possibly incremented by a destructor doing glob assignment */
2941 if (gp->gp_refcnt > 1) goto borrowed;
2942 Safefree(gp);
2943 GvGP_set(gv, NULL);
2944 }
2945
2946 int
Perl_magic_freeovrld(pTHX_ SV * sv,MAGIC * mg)2947 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2948 {
2949 AMT * const amtp = (AMT*)mg->mg_ptr;
2950 PERL_UNUSED_ARG(sv);
2951
2952 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2953
2954 if (amtp && AMT_AMAGIC(amtp)) {
2955 int i;
2956 for (i = 1; i < NofAMmeth; i++) {
2957 CV * const cv = amtp->table[i];
2958 if (cv) {
2959 SvREFCNT_dec_NN(MUTABLE_SV(cv));
2960 amtp->table[i] = NULL;
2961 }
2962 }
2963 }
2964 return 0;
2965 }
2966
2967 /* Updates and caches the CV's */
2968 /* Returns:
2969 * 1 on success and there is some overload
2970 * 0 if there is no overload
2971 * -1 if some error occurred and it couldn't croak
2972 */
2973
2974 int
Perl_Gv_AMupdate(pTHX_ HV * stash,bool destructing)2975 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2976 {
2977 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2978 AMT amt;
2979 const struct mro_meta* stash_meta = HvMROMETA(stash);
2980 U32 newgen;
2981
2982 PERL_ARGS_ASSERT_GV_AMUPDATE;
2983
2984 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2985 if (mg) {
2986 const AMT * const amtp = (AMT*)mg->mg_ptr;
2987 if (amtp->was_ok_sub == newgen) {
2988 return AMT_AMAGIC(amtp) ? 1 : 0;
2989 }
2990 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2991 }
2992
2993 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2994
2995 Zero(&amt,1,AMT);
2996 amt.was_ok_sub = newgen;
2997 amt.fallback = AMGfallNO;
2998 amt.flags = 0;
2999
3000 {
3001 int filled = 0;
3002 int i;
3003 bool deref_seen = 0;
3004
3005
3006 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
3007
3008 /* Try to find via inheritance. */
3009 GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
3010 SV * const sv = gv ? GvSV(gv) : NULL;
3011 CV* cv;
3012
3013 if (!gv)
3014 {
3015 if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
3016 goto no_table;
3017 }
3018 #ifdef PERL_DONT_CREATE_GVSV
3019 else if (!sv) {
3020 NOOP; /* Equivalent to !SvTRUE and !SvOK */
3021 }
3022 #endif
3023 else if (SvTRUE(sv))
3024 /* don't need to set overloading here because fallback => 1
3025 * is the default setting for classes without overloading */
3026 amt.fallback=AMGfallYES;
3027 else if (SvOK(sv)) {
3028 amt.fallback=AMGfallNEVER;
3029 filled = 1;
3030 }
3031 else {
3032 filled = 1;
3033 }
3034
3035 assert(SvOOK(stash));
3036 /* initially assume the worst */
3037 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
3038
3039 for (i = 1; i < NofAMmeth; i++) {
3040 const char * const cooky = PL_AMG_names[i];
3041 /* Human-readable form, for debugging: */
3042 const char * const cp = AMG_id2name(i);
3043 const STRLEN l = PL_AMG_namelens[i];
3044
3045 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
3046 cp, HvNAME_get(stash)) );
3047 /* don't fill the cache while looking up!
3048 Creation of inheritance stubs in intermediate packages may
3049 conflict with the logic of runtime method substitution.
3050 Indeed, for inheritance A -> B -> C, if C overloads "+0",
3051 then we could have created stubs for "(+0" in A and C too.
3052 But if B overloads "bool", we may want to use it for
3053 numifying instead of C's "+0". */
3054 gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
3055 cv = 0;
3056 if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) {
3057 const HEK * const gvhek = CvGvNAME_HEK(cv);
3058 const HEK * const stashek =
3059 HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)));
3060 if (memEQs(HEK_KEY(gvhek), HEK_LEN(gvhek), "nil")
3061 && stashek
3062 && memEQs(HEK_KEY(stashek), HEK_LEN(stashek), "overload")) {
3063 /* This is a hack to support autoloading..., while
3064 knowing *which* methods were declared as overloaded. */
3065 /* GvSV contains the name of the method. */
3066 GV *ngv = NULL;
3067 SV *gvsv = GvSV(gv);
3068
3069 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%" SVf256\
3070 "\" for overloaded \"%s\" in package \"%.256s\"\n",
3071 (void*)GvSV(gv), cp, HvNAME(stash)) );
3072 if (!gvsv || !SvPOK(gvsv)
3073 || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
3074 {
3075 /* Can be an import stub (created by "can"). */
3076 if (destructing) {
3077 return -1;
3078 }
3079 else {
3080 const SV * const name = (gvsv && SvPOK(gvsv))
3081 ? gvsv
3082 : newSVpvs_flags("???", SVs_TEMP);
3083 /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
3084 Perl_croak(aTHX_ "%s method \"%" SVf256
3085 "\" overloading \"%s\" "\
3086 "in package \"%" HEKf256 "\"",
3087 (GvCVGEN(gv) ? "Stub found while resolving"
3088 : "Can't resolve"),
3089 SVfARG(name), cp,
3090 HEKfARG(
3091 HvNAME_HEK(stash)
3092 ));
3093 }
3094 }
3095 cv = GvCV(gv = ngv);
3096 }
3097 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
3098 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
3099 GvNAME(CvGV(cv))) );
3100 filled = 1;
3101 } else if (gv) { /* Autoloaded... */
3102 cv = MUTABLE_CV(gv);
3103 filled = 1;
3104 }
3105 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
3106
3107 if (gv) {
3108 switch (i) {
3109 case to_sv_amg:
3110 case to_av_amg:
3111 case to_hv_amg:
3112 case to_gv_amg:
3113 case to_cv_amg:
3114 case nomethod_amg:
3115 deref_seen = 1;
3116 break;
3117 }
3118 }
3119 }
3120 if (!deref_seen)
3121 /* none of @{} etc overloaded; we can do $obj->[N] quicker.
3122 * NB - aux var invalid here, HvARRAY() could have been
3123 * reallocated since it was assigned to */
3124 HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF;
3125
3126 if (filled) {
3127 AMT_AMAGIC_on(&amt);
3128 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
3129 (char*)&amt, sizeof(AMT));
3130 return TRUE;
3131 }
3132 }
3133 /* Here we have no table: */
3134 no_table:
3135 AMT_AMAGIC_off(&amt);
3136 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
3137 (char*)&amt, sizeof(AMTS));
3138 return 0;
3139 }
3140
3141
3142 CV*
Perl_gv_handler(pTHX_ HV * stash,I32 id)3143 Perl_gv_handler(pTHX_ HV *stash, I32 id)
3144 {
3145 MAGIC *mg;
3146 AMT *amtp;
3147 U32 newgen;
3148 struct mro_meta* stash_meta;
3149
3150 if (!stash || !HvNAME_get(stash))
3151 return NULL;
3152
3153 stash_meta = HvMROMETA(stash);
3154 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
3155
3156 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
3157 if (!mg) {
3158 do_update:
3159 if (Gv_AMupdate(stash, 0) == -1)
3160 return NULL;
3161 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
3162 }
3163 assert(mg);
3164 amtp = (AMT*)mg->mg_ptr;
3165 if ( amtp->was_ok_sub != newgen )
3166 goto do_update;
3167 if (AMT_AMAGIC(amtp)) {
3168 CV * const ret = amtp->table[id];
3169 if (ret && isGV(ret)) { /* Autoloading stab */
3170 /* Passing it through may have resulted in a warning
3171 "Inherited AUTOLOAD for a non-method deprecated", since
3172 our caller is going through a function call, not a method call.
3173 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
3174 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
3175
3176 if (gv && GvCV(gv))
3177 return GvCV(gv);
3178 }
3179 return ret;
3180 }
3181
3182 return NULL;
3183 }
3184
3185
3186 /* Implement tryAMAGICun_MG macro.
3187 Do get magic, then see if the stack arg is overloaded and if so call it.
3188 Flags:
3189 AMGf_numeric apply sv_2num to the stack arg.
3190 */
3191
3192 bool
Perl_try_amagic_un(pTHX_ int method,int flags)3193 Perl_try_amagic_un(pTHX_ int method, int flags) {
3194 dSP;
3195 SV* tmpsv;
3196 SV* const arg = TOPs;
3197
3198 SvGETMAGIC(arg);
3199
3200 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
3201 AMGf_noright | AMGf_unary
3202 | (flags & AMGf_numarg))))
3203 {
3204 /* where the op is of the form:
3205 * $lex = $x op $y (where the assign is optimised away)
3206 * then assign the returned value to targ and return that;
3207 * otherwise return the value directly
3208 */
3209 if ( (PL_opargs[PL_op->op_type] & OA_TARGLEX)
3210 && (PL_op->op_private & OPpTARGET_MY))
3211 {
3212 dTARGET;
3213 sv_setsv(TARG, tmpsv);
3214 SETTARG;
3215 }
3216 else
3217 SETs(tmpsv);
3218
3219 PUTBACK;
3220 return TRUE;
3221 }
3222
3223 if ((flags & AMGf_numeric) && SvROK(arg))
3224 *sp = sv_2num(arg);
3225 return FALSE;
3226 }
3227
3228
3229 /* Implement tryAMAGICbin_MG macro.
3230 Do get magic, then see if the two stack args are overloaded and if so
3231 call it.
3232 Flags:
3233 AMGf_assign op may be called as mutator (eg +=)
3234 AMGf_numeric apply sv_2num to the stack arg.
3235 */
3236
3237 bool
Perl_try_amagic_bin(pTHX_ int method,int flags)3238 Perl_try_amagic_bin(pTHX_ int method, int flags) {
3239 dSP;
3240 SV* const left = TOPm1s;
3241 SV* const right = TOPs;
3242
3243 SvGETMAGIC(left);
3244 if (left != right)
3245 SvGETMAGIC(right);
3246
3247 if (SvAMAGIC(left) || SvAMAGIC(right)) {
3248 SV * tmpsv;
3249 /* STACKED implies mutator variant, e.g. $x += 1 */
3250 bool mutator = (flags & AMGf_assign) && (PL_op->op_flags & OPf_STACKED);
3251
3252 tmpsv = amagic_call(left, right, method,
3253 (mutator ? AMGf_assign: 0)
3254 | (flags & AMGf_numarg));
3255 if (tmpsv) {
3256 (void)POPs;
3257 /* where the op is one of the two forms:
3258 * $x op= $y
3259 * $lex = $x op $y (where the assign is optimised away)
3260 * then assign the returned value to targ and return that;
3261 * otherwise return the value directly
3262 */
3263 if ( mutator
3264 || ( (PL_opargs[PL_op->op_type] & OA_TARGLEX)
3265 && (PL_op->op_private & OPpTARGET_MY)))
3266 {
3267 dTARG;
3268 TARG = mutator ? *SP : PAD_SV(PL_op->op_targ);
3269 sv_setsv(TARG, tmpsv);
3270 SETTARG;
3271 }
3272 else
3273 SETs(tmpsv);
3274
3275 PUTBACK;
3276 return TRUE;
3277 }
3278 }
3279
3280 if(left==right && SvGMAGICAL(left)) {
3281 SV * const left = sv_newmortal();
3282 *(sp-1) = left;
3283 /* Print the uninitialized warning now, so it includes the vari-
3284 able name. */
3285 if (!SvOK(right)) {
3286 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
3287 sv_setbool(left, FALSE);
3288 }
3289 else sv_setsv_flags(left, right, 0);
3290 SvGETMAGIC(right);
3291 }
3292 if (flags & AMGf_numeric) {
3293 if (SvROK(TOPm1s))
3294 *(sp-1) = sv_2num(TOPm1s);
3295 if (SvROK(right))
3296 *sp = sv_2num(right);
3297 }
3298 return FALSE;
3299 }
3300
3301 SV *
Perl_amagic_deref_call(pTHX_ SV * ref,int method)3302 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
3303 SV *tmpsv = NULL;
3304 HV *stash;
3305
3306 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
3307
3308 if (!SvAMAGIC(ref))
3309 return ref;
3310 /* return quickly if none of the deref ops are overloaded */
3311 stash = SvSTASH(SvRV(ref));
3312 assert(SvOOK(stash));
3313 if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF)
3314 return ref;
3315
3316 while ((tmpsv = amagic_call(ref, &PL_sv_undef, method,
3317 AMGf_noright | AMGf_unary))) {
3318 if (!SvROK(tmpsv))
3319 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
3320 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
3321 /* Bail out if it returns us the same reference. */
3322 return tmpsv;
3323 }
3324 ref = tmpsv;
3325 if (!SvAMAGIC(ref))
3326 break;
3327 }
3328 return tmpsv ? tmpsv : ref;
3329 }
3330
3331 bool
Perl_amagic_is_enabled(pTHX_ int method)3332 Perl_amagic_is_enabled(pTHX_ int method)
3333 {
3334 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
3335
3336 assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
3337
3338 if ( !lex_mask || !SvOK(lex_mask) )
3339 /* overloading lexically disabled */
3340 return FALSE;
3341 else if ( lex_mask && SvPOK(lex_mask) ) {
3342 /* we have an entry in the hints hash, check if method has been
3343 * masked by overloading.pm */
3344 STRLEN len;
3345 const int offset = method / 8;
3346 const int bit = method % 8;
3347 char *pv = SvPV(lex_mask, len);
3348
3349 /* Bit set, so this overloading operator is disabled */
3350 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
3351 return FALSE;
3352 }
3353 return TRUE;
3354 }
3355
3356 SV*
Perl_amagic_call(pTHX_ SV * left,SV * right,int method,int flags)3357 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
3358 {
3359 MAGIC *mg;
3360 CV *cv=NULL;
3361 CV **cvp=NULL, **ocvp=NULL;
3362 AMT *amtp=NULL, *oamtp=NULL;
3363 int off = 0, off1, lr = 0, notfound = 0;
3364 int postpr = 0, force_cpy = 0;
3365 int assign = AMGf_assign & flags;
3366 const int assignshift = assign ? 1 : 0;
3367 int use_default_op = 0;
3368 int force_scalar = 0;
3369 #ifdef DEBUGGING
3370 int fl=0;
3371 #endif
3372 HV* stash=NULL;
3373
3374 PERL_ARGS_ASSERT_AMAGIC_CALL;
3375
3376 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
3377 if (!amagic_is_enabled(method)) return NULL;
3378 }
3379
3380 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
3381 && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
3382 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3383 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3384 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
3385 : NULL))
3386 && ((cv = cvp[off=method+assignshift])
3387 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
3388 * usual method */
3389 (
3390 #ifdef DEBUGGING
3391 fl = 1,
3392 #endif
3393 cv = cvp[off=method])))) {
3394 lr = -1; /* Call method for left argument */
3395 } else {
3396 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
3397 int logic;
3398
3399 /* look for substituted methods */
3400 /* In all the covered cases we should be called with assign==0. */
3401 switch (method) {
3402 case inc_amg:
3403 force_cpy = 1;
3404 if ((cv = cvp[off=add_ass_amg])
3405 || ((cv = cvp[off = add_amg])
3406 && (force_cpy = 0, (postpr = 1)))) {
3407 right = &PL_sv_yes; lr = -1; assign = 1;
3408 }
3409 break;
3410 case dec_amg:
3411 force_cpy = 1;
3412 if ((cv = cvp[off = subtr_ass_amg])
3413 || ((cv = cvp[off = subtr_amg])
3414 && (force_cpy = 0, (postpr=1)))) {
3415 right = &PL_sv_yes; lr = -1; assign = 1;
3416 }
3417 break;
3418 case bool__amg:
3419 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
3420 break;
3421 case numer_amg:
3422 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
3423 break;
3424 case string_amg:
3425 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
3426 break;
3427 case not_amg:
3428 (void)((cv = cvp[off=bool__amg])
3429 || (cv = cvp[off=numer_amg])
3430 || (cv = cvp[off=string_amg]));
3431 if (cv)
3432 postpr = 1;
3433 break;
3434 case copy_amg:
3435 {
3436 /*
3437 * SV* ref causes confusion with the interpreter variable of
3438 * the same name
3439 */
3440 SV* const tmpRef=SvRV(left);
3441 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
3442 /*
3443 * Just to be extra cautious. Maybe in some
3444 * additional cases sv_setsv is safe, too.
3445 */
3446 SV* const newref = newSVsv(tmpRef);
3447 SvOBJECT_on(newref);
3448 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
3449 delegate to the stash. */
3450 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
3451 return newref;
3452 }
3453 }
3454 break;
3455 case abs_amg:
3456 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
3457 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
3458 SV* const nullsv=&PL_sv_zero;
3459 if (off1==lt_amg) {
3460 SV* const lessp = amagic_call(left,nullsv,
3461 lt_amg,AMGf_noright);
3462 logic = SvTRUE_NN(lessp);
3463 } else {
3464 SV* const lessp = amagic_call(left,nullsv,
3465 ncmp_amg,AMGf_noright);
3466 logic = (SvNV(lessp) < 0);
3467 }
3468 if (logic) {
3469 if (off==subtr_amg) {
3470 right = left;
3471 left = nullsv;
3472 lr = 1;
3473 }
3474 } else {
3475 return left;
3476 }
3477 }
3478 break;
3479 case neg_amg:
3480 if ((cv = cvp[off=subtr_amg])) {
3481 right = left;
3482 left = &PL_sv_zero;
3483 lr = 1;
3484 }
3485 break;
3486 case int_amg:
3487 case iter_amg: /* XXXX Eventually should do to_gv. */
3488 case ftest_amg: /* XXXX Eventually should do to_gv. */
3489 case regexp_amg:
3490 /* FAIL safe */
3491 return NULL; /* Delegate operation to standard mechanisms. */
3492
3493 case to_sv_amg:
3494 case to_av_amg:
3495 case to_hv_amg:
3496 case to_gv_amg:
3497 case to_cv_amg:
3498 /* FAIL safe */
3499 return left; /* Delegate operation to standard mechanisms. */
3500
3501 default:
3502 goto not_found;
3503 }
3504 if (!cv) goto not_found;
3505 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
3506 && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
3507 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3508 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3509 ? (amtp = (AMT*)mg->mg_ptr)->table
3510 : NULL))
3511 && (cv = cvp[off=method])) { /* Method for right
3512 * argument found */
3513 lr=1;
3514 } else if (((cvp && amtp->fallback > AMGfallNEVER)
3515 || (ocvp && oamtp->fallback > AMGfallNEVER))
3516 && !(flags & AMGf_unary)) {
3517 /* We look for substitution for
3518 * comparison operations and
3519 * concatenation */
3520 if (method==concat_amg || method==concat_ass_amg
3521 || method==repeat_amg || method==repeat_ass_amg) {
3522 return NULL; /* Delegate operation to string conversion */
3523 }
3524 off = -1;
3525 switch (method) {
3526 case lt_amg:
3527 case le_amg:
3528 case gt_amg:
3529 case ge_amg:
3530 case eq_amg:
3531 case ne_amg:
3532 off = ncmp_amg;
3533 break;
3534 case slt_amg:
3535 case sle_amg:
3536 case sgt_amg:
3537 case sge_amg:
3538 case seq_amg:
3539 case sne_amg:
3540 off = scmp_amg;
3541 break;
3542 }
3543 if (off != -1) {
3544 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
3545 cv = ocvp[off];
3546 lr = -1;
3547 }
3548 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
3549 cv = cvp[off];
3550 lr = 1;
3551 }
3552 }
3553 if (cv)
3554 postpr = 1;
3555 else
3556 goto not_found;
3557 } else {
3558 not_found: /* No method found, either report or croak */
3559 switch (method) {
3560 case to_sv_amg:
3561 case to_av_amg:
3562 case to_hv_amg:
3563 case to_gv_amg:
3564 case to_cv_amg:
3565 /* FAIL safe */
3566 return left; /* Delegate operation to standard mechanisms. */
3567 }
3568 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
3569 notfound = 1; lr = -1;
3570 } else if (cvp && (cv=cvp[nomethod_amg])) {
3571 notfound = 1; lr = 1;
3572 } else if ((use_default_op =
3573 (!ocvp || oamtp->fallback >= AMGfallYES)
3574 && (!cvp || amtp->fallback >= AMGfallYES))
3575 && !DEBUG_o_TEST) {
3576 /* Skip generating the "no method found" message. */
3577 return NULL;
3578 } else {
3579 SV *msg;
3580 if (off==-1) off=method;
3581 msg = sv_2mortal(Perl_newSVpvf(aTHX_
3582 "Operation \"%s\": no method found,%sargument %s%" SVf "%s%" SVf,
3583 AMG_id2name(method + assignshift),
3584 (flags & AMGf_unary ? " " : "\n\tleft "),
3585 SvAMAGIC(left)?
3586 "in overloaded package ":
3587 "has no overloaded magic",
3588 SvAMAGIC(left)?
3589 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
3590 SVfARG(&PL_sv_no),
3591 SvAMAGIC(right)?
3592 ",\n\tright argument in overloaded package ":
3593 (flags & AMGf_unary
3594 ? ""
3595 : ",\n\tright argument has no overloaded magic"),
3596 SvAMAGIC(right)?
3597 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
3598 SVfARG(&PL_sv_no)));
3599 if (use_default_op) {
3600 DEBUG_o( Perl_deb(aTHX_ "%" SVf, SVfARG(msg)) );
3601 } else {
3602 Perl_croak(aTHX_ "%" SVf, SVfARG(msg));
3603 }
3604 return NULL;
3605 }
3606 force_cpy = force_cpy || assign;
3607 }
3608 }
3609
3610 switch (method) {
3611 /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
3612 * operation. we need this to return a value, so that it can be assigned
3613 * later on, in the postpr block (case inc_amg/dec_amg), even if the
3614 * increment or decrement was itself called in void context */
3615 case inc_amg:
3616 if (off == add_amg)
3617 force_scalar = 1;
3618 break;
3619 case dec_amg:
3620 if (off == subtr_amg)
3621 force_scalar = 1;
3622 break;
3623 /* in these cases, we're calling an assignment variant of an operator
3624 * (+= rather than +, for instance). regardless of whether it's a
3625 * fallback or not, it always has to return a value, which will be
3626 * assigned to the proper variable later */
3627 case add_amg:
3628 case subtr_amg:
3629 case mult_amg:
3630 case div_amg:
3631 case modulo_amg:
3632 case pow_amg:
3633 case lshift_amg:
3634 case rshift_amg:
3635 case repeat_amg:
3636 case concat_amg:
3637 case band_amg:
3638 case bor_amg:
3639 case bxor_amg:
3640 case sband_amg:
3641 case sbor_amg:
3642 case sbxor_amg:
3643 if (assign)
3644 force_scalar = 1;
3645 break;
3646 /* the copy constructor always needs to return a value */
3647 case copy_amg:
3648 force_scalar = 1;
3649 break;
3650 /* because of the way these are implemented (they don't perform the
3651 * dereferencing themselves, they return a reference that perl then
3652 * dereferences later), they always have to be in scalar context */
3653 case to_sv_amg:
3654 case to_av_amg:
3655 case to_hv_amg:
3656 case to_gv_amg:
3657 case to_cv_amg:
3658 force_scalar = 1;
3659 break;
3660 /* these don't have an op of their own; they're triggered by their parent
3661 * op, so the context there isn't meaningful ('$a and foo()' in void
3662 * context still needs to pass scalar context on to $a's bool overload) */
3663 case bool__amg:
3664 case numer_amg:
3665 case string_amg:
3666 force_scalar = 1;
3667 break;
3668 }
3669
3670 #ifdef DEBUGGING
3671 if (!notfound) {
3672 DEBUG_o(Perl_deb(aTHX_
3673 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %" SVf "%s\n",
3674 AMG_id2name(off),
3675 method+assignshift==off? "" :
3676 " (initially \"",
3677 method+assignshift==off? "" :
3678 AMG_id2name(method+assignshift),
3679 method+assignshift==off? "" : "\")",
3680 flags & AMGf_unary? "" :
3681 lr==1 ? " for right argument": " for left argument",
3682 flags & AMGf_unary? " for argument" : "",
3683 stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
3684 fl? ",\n\tassignment variant used": "") );
3685 }
3686 #endif
3687 /* Since we use shallow copy during assignment, we need
3688 * to dublicate the contents, probably calling user-supplied
3689 * version of copy operator
3690 */
3691 /* We need to copy in following cases:
3692 * a) Assignment form was called.
3693 * assignshift==1, assign==T, method + 1 == off
3694 * b) Increment or decrement, called directly.
3695 * assignshift==0, assign==0, method + 0 == off
3696 * c) Increment or decrement, translated to assignment add/subtr.
3697 * assignshift==0, assign==T,
3698 * force_cpy == T
3699 * d) Increment or decrement, translated to nomethod.
3700 * assignshift==0, assign==0,
3701 * force_cpy == T
3702 * e) Assignment form translated to nomethod.
3703 * assignshift==1, assign==T, method + 1 != off
3704 * force_cpy == T
3705 */
3706 /* off is method, method+assignshift, or a result of opcode substitution.
3707 * In the latter case assignshift==0, so only notfound case is important.
3708 */
3709 if ( (lr == -1) && ( ( (method + assignshift == off)
3710 && (assign || (method == inc_amg) || (method == dec_amg)))
3711 || force_cpy) )
3712 {
3713 /* newSVsv does not behave as advertised, so we copy missing
3714 * information by hand */
3715 SV *tmpRef = SvRV(left);
3716 SV *rv_copy;
3717 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
3718 SvRV_set(left, rv_copy);
3719 SvSETMAGIC(left);
3720 SvREFCNT_dec_NN(tmpRef);
3721 }
3722 }
3723
3724 {
3725 dSP;
3726 BINOP myop;
3727 SV* res;
3728 const bool oldcatch = CATCH_GET;
3729 I32 oldmark, nret;
3730 /* for multiconcat, we may call overload several times,
3731 * with the context of individual concats being scalar,
3732 * regardless of the overall context of the multiconcat op
3733 */
3734 U8 gimme = (force_scalar || PL_op->op_type == OP_MULTICONCAT)
3735 ? G_SCALAR : GIMME_V;
3736
3737 CATCH_SET(TRUE);
3738 Zero(&myop, 1, BINOP);
3739 myop.op_last = (OP *) &myop;
3740 myop.op_next = NULL;
3741 myop.op_flags = OPf_STACKED;
3742
3743 switch (gimme) {
3744 case G_VOID:
3745 myop.op_flags |= OPf_WANT_VOID;
3746 break;
3747 case G_LIST:
3748 if (flags & AMGf_want_list) {
3749 myop.op_flags |= OPf_WANT_LIST;
3750 break;
3751 }
3752 /* FALLTHROUGH */
3753 default:
3754 myop.op_flags |= OPf_WANT_SCALAR;
3755 break;
3756 }
3757
3758 PUSHSTACKi(PERLSI_OVERLOAD);
3759 ENTER;
3760 SAVEOP();
3761 PL_op = (OP *) &myop;
3762 if (PERLDB_SUB && PL_curstash != PL_debstash)
3763 PL_op->op_private |= OPpENTERSUB_DB;
3764 Perl_pp_pushmark(aTHX);
3765
3766 EXTEND(SP, notfound + 5);
3767 PUSHs(lr>0? right: left);
3768 PUSHs(lr>0? left: right);
3769 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3770 if (notfound) {
3771 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3772 AMG_id2namelen(method + assignshift), SVs_TEMP));
3773 }
3774 else if (flags & AMGf_numarg)
3775 PUSHs(&PL_sv_undef);
3776 if (flags & AMGf_numarg)
3777 PUSHs(&PL_sv_yes);
3778 PUSHs(MUTABLE_SV(cv));
3779 PUTBACK;
3780 oldmark = TOPMARK;
3781
3782 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3783 CALLRUNOPS(aTHX);
3784 LEAVE;
3785 SPAGAIN;
3786 nret = SP - (PL_stack_base + oldmark);
3787
3788 switch (gimme) {
3789 case G_VOID:
3790 /* returning NULL has another meaning, and we check the context
3791 * at the call site too, so this can be differentiated from the
3792 * scalar case */
3793 res = &PL_sv_undef;
3794 SP = PL_stack_base + oldmark;
3795 break;
3796 case G_LIST:
3797 if (flags & AMGf_want_list) {
3798 res = sv_2mortal((SV *)newAV());
3799 av_extend((AV *)res, nret);
3800 while (nret--)
3801 av_store((AV *)res, nret, POPs);
3802 break;
3803 }
3804 /* FALLTHROUGH */
3805 default:
3806 res = POPs;
3807 break;
3808 }
3809
3810 PUTBACK;
3811 POPSTACK;
3812 CATCH_SET(oldcatch);
3813
3814 if (postpr) {
3815 int ans;
3816 switch (method) {
3817 case le_amg:
3818 case sle_amg:
3819 ans=SvIV(res)<=0; break;
3820 case lt_amg:
3821 case slt_amg:
3822 ans=SvIV(res)<0; break;
3823 case ge_amg:
3824 case sge_amg:
3825 ans=SvIV(res)>=0; break;
3826 case gt_amg:
3827 case sgt_amg:
3828 ans=SvIV(res)>0; break;
3829 case eq_amg:
3830 case seq_amg:
3831 ans=SvIV(res)==0; break;
3832 case ne_amg:
3833 case sne_amg:
3834 ans=SvIV(res)!=0; break;
3835 case inc_amg:
3836 case dec_amg:
3837 SvSetSV(left,res); return left;
3838 case not_amg:
3839 ans=!SvTRUE_NN(res); break;
3840 default:
3841 ans=0; break;
3842 }
3843 return boolSV(ans);
3844 } else if (method==copy_amg) {
3845 if (!SvROK(res)) {
3846 Perl_croak(aTHX_ "Copy method did not return a reference");
3847 }
3848 return SvREFCNT_inc(SvRV(res));
3849 } else {
3850 return res;
3851 }
3852 }
3853 }
3854
3855 void
Perl_gv_name_set(pTHX_ GV * gv,const char * name,U32 len,U32 flags)3856 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3857 {
3858 U32 hash;
3859
3860 PERL_ARGS_ASSERT_GV_NAME_SET;
3861
3862 if (len > I32_MAX)
3863 Perl_croak(aTHX_ "panic: gv name too long (%" UVuf ")", (UV) len);
3864
3865 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3866 unshare_hek(GvNAME_HEK(gv));
3867 }
3868
3869 PERL_HASH(hash, name, len);
3870 GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3871 }
3872
3873 /*
3874 =for apidoc gv_try_downgrade
3875
3876 If the typeglob C<gv> can be expressed more succinctly, by having
3877 something other than a real GV in its place in the stash, replace it
3878 with the optimised form. Basic requirements for this are that C<gv>
3879 is a real typeglob, is sufficiently ordinary, and is only referenced
3880 from its package. This function is meant to be used when a GV has been
3881 looked up in part to see what was there, causing upgrading, but based
3882 on what was found it turns out that the real GV isn't required after all.
3883
3884 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3885
3886 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3887 sub, the typeglob is replaced with a scalar-reference placeholder that
3888 more compactly represents the same thing.
3889
3890 =cut
3891 */
3892
3893 void
Perl_gv_try_downgrade(pTHX_ GV * gv)3894 Perl_gv_try_downgrade(pTHX_ GV *gv)
3895 {
3896 HV *stash;
3897 CV *cv;
3898 HEK *namehek;
3899 SV **gvp;
3900 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3901
3902 /* XXX Why and where does this leave dangling pointers during global
3903 destruction? */
3904 if (PL_phase == PERL_PHASE_DESTRUCT) return;
3905
3906 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3907 !SvOBJECT(gv) && !SvREADONLY(gv) &&
3908 isGV_with_GP(gv) && GvGP(gv) &&
3909 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3910 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3911 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3912 return;
3913 if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv)
3914 return;
3915 if (SvMAGICAL(gv)) {
3916 MAGIC *mg;
3917 /* only backref magic is allowed */
3918 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3919 return;
3920 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3921 if (mg->mg_type != PERL_MAGIC_backref)
3922 return;
3923 }
3924 }
3925 cv = GvCV(gv);
3926 if (!cv) {
3927 HEK *gvnhek = GvNAME_HEK(gv);
3928 (void)hv_deletehek(stash, gvnhek, G_DISCARD);
3929 } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
3930 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3931 CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv &&
3932 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3933 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3934 (namehek = GvNAME_HEK(gv)) &&
3935 (gvp = hv_fetchhek(stash, namehek, 0)) &&
3936 *gvp == (SV*)gv) {
3937 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3938 const bool imported = !!GvIMPORTED_CV(gv);
3939 SvREFCNT(gv) = 0;
3940 sv_clear((SV*)gv);
3941 SvREFCNT(gv) = 1;
3942 SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
3943
3944 /* See also: 'SET_SVANY_FOR_BODYLESS_IV' in sv.c */
3945 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3946 STRUCT_OFFSET(XPVIV, xiv_iv));
3947 SvRV_set(gv, value);
3948 }
3949 }
3950
3951 GV *
Perl_gv_override(pTHX_ const char * const name,const STRLEN len)3952 Perl_gv_override(pTHX_ const char * const name, const STRLEN len)
3953 {
3954 GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV);
3955 GV * const *gvp;
3956 PERL_ARGS_ASSERT_GV_OVERRIDE;
3957 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv;
3958 gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE);
3959 gv = gvp ? *gvp : NULL;
3960 if (gv && !isGV(gv)) {
3961 if (!SvPCS_IMPORTED(gv)) return NULL;
3962 gv_init(gv, PL_globalstash, name, len, 0);
3963 return gv;
3964 }
3965 return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL;
3966 }
3967
3968 #include "XSUB.h"
3969
3970 static void
core_xsub(pTHX_ CV * cv)3971 core_xsub(pTHX_ CV* cv)
3972 {
3973 Perl_croak(aTHX_
3974 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3975 );
3976 }
3977
3978 /*
3979 * ex: set ts=8 sts=4 sw=4 et:
3980 */
3981