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