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
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.
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,'
19 * [p.599 of _The Lord of the Rings_, III/xi: "The PalantÃr"]
23 =head1 GV Handling and Stashes
24 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
25 It is a structure that holds a pointer to a scalar, an array, a hash etc,
26 corresponding to $foo, @foo, %foo.
28 GVs are usually found as values in stashes (symbol table hashes) where
29 Perl stores its global variables.
31 A B<stash> is a hash that contains all variables that are defined
32 within a package. See L<perlguts/Stashes and Globs>
42 #include "overload.inc"
46 static const char S_autoload[] = "AUTOLOAD";
47 #define S_autolen (sizeof("AUTOLOAD")-1)
50 =for apidoc gv_add_by_type
52 Make sure there is a slot of type C<type> in the GV C<gv>.
58 Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
65 SvTYPE((const SV *)gv) != SVt_PVGV
66 && SvTYPE((const SV *)gv) != SVt_PVLV
70 if (type == SVt_PVIO) {
72 * if it walks like a dirhandle, then let's assume that
73 * this is a dirhandle.
75 what = OP_IS_DIRHOP(PL_op->op_type) ?
76 "dirhandle" : "filehandle";
77 } else if (type == SVt_PVHV) {
80 what = type == SVt_PVAV ? "array" : "scalar";
82 Perl_croak(aTHX_ "Bad symbol for %s", what);
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);
97 *where = newSV_type(type);
99 && memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA"))
101 sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
108 =for apidoc gv_fetchfile
109 =for apidoc_item gv_fetchfile_flags
111 These return the debugger glob for the file (compiled by Perl) whose name is
112 given by the C<name> parameter.
114 There are currently exactly two differences between these functions.
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>).
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
129 Perl_gv_fetchfile(pTHX_ const char *name)
131 PERL_ARGS_ASSERT_GV_FETCHFILE;
132 return gv_fetchfile_flags(name, strlen(name), 0);
136 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
141 const STRLEN tmplen = namelen + 2;
144 PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
145 PERL_UNUSED_ARG(flags);
150 if (tmplen <= sizeof smallbuf)
153 Newx(tmpbuf, tmplen, char);
154 /* This is where the debugger's %{"::_<$filename"} hash is created */
157 memcpy(tmpbuf + 2, name, namelen);
158 GV **gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, (flags & GVF_NOADD) ? FALSE : TRUE);
162 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
163 #ifdef PERL_DONT_CREATE_GVSV
164 GvSV(gv) = newSVpvn(name, namelen);
166 sv_setpvn(GvSV(gv), name, namelen);
169 if (PERLDB_LINE_OR_SAVESRC && !GvAV(gv))
170 hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile);
175 if (tmpbuf != smallbuf)
181 =for apidoc gv_const_sv
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
192 Perl_gv_const_sv(pTHX_ GV *gv)
194 PERL_ARGS_ASSERT_GV_CONST_SV;
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;
203 Perl_newGP(pTHX_ GV *const gv)
213 PERL_ARGS_ASSERT_NEWGP;
215 gp->gp_egv = gv; /* allow compiler to reuse gv after this */
216 #ifndef PERL_DONT_CREATE_GVSV
217 gp->gp_sv = newSV_type(SVt_NULL);
220 /* PL_curcop may be null here. E.g.,
221 INIT { bless {} and exit }
222 frees INIT before looking up DESTROY (and creating *DESTROY)
225 gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
227 if (CopFILE(PL_curcop)) {
228 file = CopFILE(PL_curcop);
232 filegv = CopFILEGV(PL_curcop);
234 file = GvNAME(filegv)+2;
235 len = GvNAMELEN(filegv)-2;
246 PERL_HASH(hash, file, len);
247 gp->gp_file_hek = share_hek(file, len, hash);
253 /* Assign CvGV(cv) = gv, handling weak references.
254 * See also S_anonymise_cv_maybe */
257 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
259 GV * const oldgv = CvNAMED(cv) ? NULL : SvANY(cv)->xcv_gv_u.xcv_gv;
261 PERL_ARGS_ASSERT_CVGV_SET;
268 SvREFCNT_dec_NN(oldgv);
272 sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
275 else if ((hek = CvNAME_HEK(cv))) {
281 SvANY(cv)->xcv_gv_u.xcv_gv = gv;
282 assert(!CvCVGV_RC(cv));
287 if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
288 Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
291 SvREFCNT_inc_simple_void_NN(gv);
295 /* Convert CvSTASH + CvNAME_HEK into a GV. Conceptually, all subs have a
296 GV, but for efficiency that GV may not in fact exist. This function,
297 called by CvGV, reifies it. */
300 Perl_cvgv_from_hek(pTHX_ CV *cv)
304 PERL_ARGS_ASSERT_CVGV_FROM_HEK;
305 assert(SvTYPE(cv) == SVt_PVCV);
306 if (!CvSTASH(cv)) return NULL;
307 ASSUME(CvNAME_HEK(cv));
308 svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0);
309 gv = MUTABLE_GV(svp && *svp ? *svp : newSV_type(SVt_NULL));
311 gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)),
312 HEK_LEN(CvNAME_HEK(cv)),
313 SVf_UTF8 * cBOOL(HEK_UTF8(CvNAME_HEK(cv))));
314 if (!CvNAMED(cv)) { /* gv_init took care of it */
315 assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv);
318 unshare_hek(CvNAME_HEK(cv));
320 SvANY(cv)->xcv_gv_u.xcv_gv = gv;
321 if (svp && *svp) SvREFCNT_inc_simple_void_NN(gv);
326 /* Assign CvSTASH(cv) = st, handling weak references. */
329 Perl_cvstash_set(pTHX_ CV *cv, HV *st)
331 HV *oldst = CvSTASH(cv);
332 PERL_ARGS_ASSERT_CVSTASH_SET;
336 sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
337 SvANY(cv)->xcv_stash = st;
339 Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
343 =for apidoc gv_init_pvn
345 Converts a scalar into a typeglob. This is an incoercible typeglob;
346 assigning a reference to it will assign to one of its slots, instead of
347 overwriting it as happens with typeglobs created by C<SvSetSV>. Converting
348 any scalar that is C<SvOK()> may produce unpredictable results and is reserved
349 for perl's internal use.
351 C<gv> is the scalar to be converted.
353 C<stash> is the parent stash/package, if any.
355 C<name> and C<len> give the name. The name must be unqualified;
356 that is, it must not include the package name. If C<gv> is a
357 stash element, it is the caller's responsibility to ensure that the name
358 passed to this function matches the name of the element. If it does not
359 match, perl's internal bookkeeping will get out of sync.
361 C<flags> can be set to C<SVf_UTF8> if C<name> is a UTF-8 string, or
362 the return value of SvUTF8(sv). It can also take the
363 C<GV_ADDMULTI> flag, which means to pretend that the GV has been
364 seen before (i.e., suppress "Used once" warnings).
366 =for apidoc Amnh||GV_ADDMULTI
370 The old form of C<gv_init_pvn()>. It does not work with UTF-8 strings, as it
371 has no flags parameter. If the C<multi> parameter is set, the
372 C<GV_ADDMULTI> flag will be passed to C<gv_init_pvn()>.
374 =for apidoc gv_init_pv
376 Same as C<gv_init_pvn()>, but takes a nul-terminated string for the name
377 instead of separate char * and length parameters.
379 =for apidoc gv_init_sv
381 Same as C<gv_init_pvn()>, but takes an SV * for the name instead of separate
382 char * and length parameters. C<flags> is currently unused.
388 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
392 PERL_ARGS_ASSERT_GV_INIT_SV;
393 namepv = SvPV(namesv, namelen);
396 gv_init_pvn(gv, stash, namepv, namelen, flags);
400 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
402 PERL_ARGS_ASSERT_GV_INIT_PV;
403 gv_init_pvn(gv, stash, name, strlen(name), flags);
406 /* Packages in the symbol table are "stashes" - hashes where the keys are symbol
407 names and the values are typeglobs. The value $foo::bar is actually found
408 by looking up the typeglob *foo::{bar} and then reading its SCALAR slot.
410 At least, that's what you see in Perl space if you use typeglob syntax.
411 Usually it's also what's actually stored in the stash, but for some cases
412 different values are stored (as a space optimisation) and converted to full
413 typeglobs "on demand" - if a typeglob syntax is used to read a value. It's
414 the job of this function, Perl_gv_init_pvn(), to undo any trickery and
415 replace the SV stored in the stash with the regular PVGV structure that it is
416 a shorthand for. This has to be done "in-place" by upgrading the actual SV
417 that is already stored in the stash to a PVGV.
419 As the public documentation above says:
420 Converting any scalar that is C<SvOK()> may produce unpredictable
421 results and is reserved for perl's internal use.
423 Values that can be stored:
425 * plain scalar - a subroutine declaration
426 The scalar's string value is the subroutine prototype; the integer -1 is
427 "no prototype". ie shorthand for sub foo ($$); or sub bar;
428 * reference to a scalar - a constant. ie shorthand for sub PI() { 4; }
429 * reference to a sub - a subroutine (avoids allocating a PVGV)
431 The earliest optimisation was subroutine declarations, implemented in 1998
432 by commit 8472ac73d6d80294:
433 "Sub declaration cost reduced from ~500 to ~100 bytes"
435 This space optimisation needs to be invisible to regular Perl code. For this
441 When the first line is compiled, the optimisation is used, and $::{foo} is
442 assigned the scalar '$$'. No PVGV or PVCV is created.
444 When the second line encountered, the typeglob lookup on foo needs to
445 "upgrade" the symbol table entry to a PVGV, and then create a PVCV in the
446 {CODE} slot with the prototype $$ and no body. The typeglob is then available
447 so that [] can be assigned to the {ARRAY} slot. For the code above the
448 upgrade happens at compile time, the assignment at runtime.
450 Analogous code unwinds the other optimisations.
453 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
455 const U32 old_type = SvTYPE(gv);
456 const bool doproto = old_type > SVt_NULL;
457 char * const proto = (doproto && SvPOK(gv))
458 ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
460 const STRLEN protolen = proto ? SvCUR(gv) : 0;
461 const U32 proto_utf8 = proto ? SvUTF8(gv) : 0;
462 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
463 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
464 const bool really_sub =
465 has_constant && SvTYPE(has_constant) == SVt_PVCV;
466 COP * const old = PL_curcop;
468 PERL_ARGS_ASSERT_GV_INIT_PVN;
469 assert (!(proto && has_constant));
472 /* The constant has to be a scalar, array or subroutine. */
473 switch (SvTYPE(has_constant)) {
477 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
478 sv_reftype(has_constant, 0));
479 NOT_REACHED; /* NOTREACHED */
489 if (old_type < SVt_PVGV) {
490 if (old_type >= SVt_PV)
492 sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
496 /* For this case, we are "stealing" the buffer from the SvPV and
497 re-attaching to an SV below with the call to sv_usepvn_flags().
498 Hence we don't free it. */
502 /* There is no valid prototype. (SvPOK() must be true for a valid
503 prototype.) Hence we free the memory. */
504 Safefree(SvPVX_mutable(gv));
512 if (really_sub && !CvISXSUB(has_constant) && CvSTART(has_constant)
513 && ( CvSTART(has_constant)->op_type == OP_NEXTSTATE
514 || CvSTART(has_constant)->op_type == OP_DBSTATE))
515 PL_curcop = (COP *)CvSTART(has_constant);
516 GvGP_set(gv, Perl_newGP(aTHX_ gv));
520 Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
521 gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
522 if (flags & GV_ADDMULTI || doproto) /* doproto means it */
523 GvMULTI_on(gv); /* _was_ mentioned */
525 /* Not actually a constant. Just a regular sub. */
526 CV * const cv = (CV *)has_constant;
528 if (CvNAMED(cv) && CvSTASH(cv) == stash && (
529 CvNAME_HEK(cv) == GvNAME_HEK(gv)
530 || ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
531 && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
532 && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv))
533 && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv))
541 /* newCONSTSUB takes ownership of the reference from us. */
542 cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
543 /* In case op.c:S_process_special_blocks stole it: */
545 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
546 assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
547 /* If this reference was a copy of another, then the subroutine
548 must have been "imported", by a Perl space assignment to a GV
549 from a reference to CV. */
550 if (exported_constant)
551 GvIMPORTED_CV_on(gv);
552 CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
557 sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
558 SV_HAS_TRAILING_NUL);
559 if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
565 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
567 PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
579 #ifdef PERL_DONT_CREATE_GVSV
587 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
588 If we just cast GvSVn(gv) to void, it ignores evaluating it for
595 static void core_xsub(pTHX_ CV* cv);
598 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
599 const char * const name, const STRLEN len)
601 const int code = keyword(name, len, 1);
602 static const char file[] = __FILE__;
603 CV *cv, *oldcompcv = NULL;
605 bool ampable = TRUE; /* &{}-able */
606 COP *oldcurcop = NULL;
607 yy_parser *oldparser = NULL;
608 I32 oldsavestack_ix = 0;
613 if (!code) return NULL; /* Not a keyword */
614 switch (code < 0 ? -code : code) {
615 /* no support for \&CORE::infix;
616 no support for funcs that do not parse like funcs */
617 case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
618 case KEY_BEGIN : case KEY_CHECK : case KEY_catch : case KEY_cmp:
619 case KEY_default : case KEY_defer : case KEY_DESTROY:
620 case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif :
621 case KEY_END : case KEY_eq : case KEY_eval : case KEY_finally:
622 case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge :
623 case KEY_given : case KEY_goto : case KEY_grep : case KEY_gt :
624 case KEY_if : case KEY_isa : case KEY_INIT : case KEY_last :
625 case KEY_le : case KEY_local : case KEY_lt : case KEY_m :
626 case KEY_map : case KEY_my:
627 case KEY_ne : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
628 case KEY_package: case KEY_print: case KEY_printf:
629 case KEY_q : case KEY_qq : case KEY_qr : case KEY_qw :
630 case KEY_qx : case KEY_redo : case KEY_require: case KEY_return:
631 case KEY_s : case KEY_say : case KEY_sort :
632 case KEY_state: case KEY_sub :
633 case KEY_tr : case KEY_try : case KEY_UNITCHECK: case KEY_unless:
634 case KEY_until: case KEY_use : case KEY_when : case KEY_while :
635 case KEY_x : case KEY_xor : case KEY_y :
638 case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
639 case KEY_eof : case KEY_exec: case KEY_exists :
644 case KEY_truncate: case KEY_unlink:
648 gv = (GV *)newSV_type(SVt_NULL);
649 gv_init(gv, stash, name, len, TRUE);
654 oldcurcop = PL_curcop;
655 oldparser = PL_parser;
656 lex_start(NULL, NULL, 0);
657 oldcompcv = PL_compcv;
658 PL_compcv = NULL; /* Prevent start_subparse from setting
660 oldsavestack_ix = start_subparse(FALSE,0);
664 /* Avoid calling newXS, as it calls us, and things start to
666 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
670 CvXSUB(cv) = core_xsub;
673 CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
675 /* XSUBs can't be perl lang/perl5db.pl debugged
676 if (PERLDB_LINE_OR_SAVESRC)
677 (void)gv_fetchfile(file); */
678 CvFILE(cv) = (char *)file;
679 /* XXX This is inefficient, as doing things this order causes
680 a prototype check in newATTRSUB. But we have to do
681 it this order as we need an op number before calling
683 (void)core_prototype((SV *)cv, name, code, &opnum);
685 (void)hv_store(stash,name,len,(SV *)gv,0);
691 /* newATTRSUB will free the CV and return NULL if we're still
692 compiling after a syntax error */
693 if ((cv = newATTRSUB_x(
694 oldsavestack_ix, (OP *)gv,
699 : newSVpvn(name,len),
704 assert(GvCV(gv) == orig_cv);
705 if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
706 && opnum != OP_UNDEF && opnum != OP_KEYS)
707 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
710 PL_parser = oldparser;
711 PL_curcop = oldcurcop;
712 PL_compcv = oldcompcv;
715 SV *opnumsv = newSViv(
716 (opnum == OP_ENTEREVAL && len == 9 && memEQ(name, "evalbytes", 9)) ?
717 (OP_ENTEREVAL | (1<<16))
718 : opnum ? opnum : (((I32)name[2]) << 16));
719 cv_set_call_checker_flags(cv, Perl_ck_entersub_args_core, opnumsv, 0);
720 SvREFCNT_dec_NN(opnumsv);
727 =for apidoc gv_fetchmeth
728 =for apidoc_item gv_fetchmeth_pv
729 =for apidoc_item gv_fetchmeth_pvn
730 =for apidoc_item gv_fetchmeth_sv
732 These each look for a glob with name C<name>, containing a defined subroutine,
733 returning the GV of that glob if found, or C<NULL> if not.
735 C<stash> is always searched (first), unless it is C<NULL>.
737 If C<stash> is NULL, or was searched but nothing was found in it, and the
738 C<GV_SUPER> bit is set in C<flags>, stashes accessible via C<@ISA> are searched
739 next. Searching is conducted according to L<C<MRO> order|perlmroapi>.
741 Finally, if no matches were found so far, and the C<GV_NOUNIVERSAL> flag in
742 C<flags> is not set, C<UNIVERSAL::> is searched.
744 The argument C<level> should be either 0 or -1. If -1, the function will
745 return without any side effects or caching. If 0, the function makes sure
746 there is a glob named C<name> in C<stash>, creating one if necessary.
747 The subroutine slot in the glob will be set to any subroutine found in the
748 C<stash> and C<SUPER::> search, hence caching any C<SUPER::> result. Note that
749 subroutines found in C<UNIVERSAL::> are not cached.
751 The GV returned from these may be a method cache entry, which is not visible to
752 Perl code. So when calling C<call_sv>, you should not use the GV directly;
753 instead, you should use the method's CV, which can be obtained from the GV with
756 The only other significant value for C<flags> is C<SVf_UTF8>, indicating that
757 C<name> is to be treated as being encoded in UTF-8.
759 Plain C<gv_fetchmeth> lacks a C<flags> parameter, hence always searches in
760 C<stash>, then C<UNIVERSAL::>, and C<name> is never UTF-8. Otherwise it is
761 exactly like C<gv_fetchmeth_pvn>.
763 The other forms do have a C<flags> parameter, and differ only in how the glob
766 In C<gv_fetchmeth_pv>, C<name> is a C language NUL-terminated string.
768 In C<gv_fetchmeth_pvn>, C<name> points to the first byte of the name, and an
769 additional parameter, C<len>, specifies its length in bytes. Hence, the name
770 may contain embedded-NUL characters.
772 In C<gv_fetchmeth_sv>, C<*name> is an SV, and the name is the PV extracted from
773 that, using L</C<SvPV>>. If the SV is marked as being in UTF-8, the extracted
776 =for apidoc Amnh||GV_SUPER
782 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
786 PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
787 if (LIKELY(SvPOK_nog(namesv))) /* common case */
788 return gv_fetchmeth_internal(stash, namesv, NULL, 0, level,
789 flags | SvUTF8(namesv));
790 namepv = SvPV(namesv, namelen);
791 if (SvUTF8(namesv)) flags |= SVf_UTF8;
792 return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
797 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
799 PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
800 return gv_fetchmeth_internal(stash, NULL, name, strlen(name), level, flags);
803 /* NOTE: No support for tied ISA */
805 PERL_STATIC_INLINE GV*
806 S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, I32 level, U32 flags)
813 HV* cstash, *cachestash;
814 GV* candidate = NULL;
819 I32 create = (level >= 0) ? HV_FETCH_LVALUE : 0;
822 U32 is_utf8 = flags & SVf_UTF8;
824 /* UNIVERSAL methods should be callable without a stash */
826 create = 0; /* probably appropriate */
827 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
833 hvname = HvNAME_get(stash);
834 hvnamelen = HvNAMELEN_get(stash);
836 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
839 assert(name || meth);
841 DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
842 flags & GV_SUPER ? "SUPER " : "",
843 name ? name : SvPV_nolen(meth), hvname) );
845 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
847 if (flags & GV_SUPER) {
848 if (!HvAUX(stash)->xhv_mro_meta->super)
849 HvAUX(stash)->xhv_mro_meta->super = newHV();
850 cachestash = HvAUX(stash)->xhv_mro_meta->super;
852 else cachestash = stash;
854 /* check locally for a real method or a cache entry */
856 cachestash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, create, NULL, 0
858 if (he) gvp = (GV**)&HeVAL(he);
865 if (SvTYPE(topgv) != SVt_PVGV)
868 name = SvPV_nomg(meth, len);
869 gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
871 if ((cand_cv = GvCV(topgv))) {
872 /* If genuine method or valid cache entry, use it */
873 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
877 /* stale cache entry, junk it and move on */
878 SvREFCNT_dec_NN(cand_cv);
879 GvCV_set(topgv, NULL);
884 else if (GvCVGEN(topgv) == topgen_cmp) {
885 /* cache indicates no such method definitively */
888 else if (stash == cachestash
889 && len > 1 /* shortest is uc */
890 && memEQs(hvname, HvNAMELEN_get(stash), "CORE")
891 && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
895 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
896 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
897 items = AvFILLp(linear_av); /* no +1, to skip over self */
899 linear_sv = *linear_svp++;
901 cstash = gv_stashsv(linear_sv, 0);
904 if ( ckWARN(WARN_SYNTAX)) {
905 if( /* these are loaded from Perl_Gv_AMupdate() one way or another */
906 ( len && name[0] == '(' ) /* overload.pm related, in particular "()" */
907 || ( memEQs( name, len, "DESTROY") )
909 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
910 "Can't locate package %" SVf " for @%" HEKf "::ISA",
912 HEKfARG(HvNAME_HEK(stash)));
914 } else if( memEQs( name, len, "AUTOLOAD") ) {
915 /* gobble this warning */
917 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
918 "While trying to resolve method call %.*s->%.*s()"
919 " can not locate package %" SVf_QUOTEDPREFIX " yet it is mentioned in @%.*s::ISA"
920 " (perhaps you forgot to load %" SVf_QUOTEDPREFIX "?)",
921 (int) hvnamelen, hvname,
924 (int) hvnamelen, hvname,
933 gvp = (GV**)hv_common(
934 cstash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, HV_FETCH_JUST_SV, NULL, 0
937 if (len > 1 && HvNAMELEN_get(cstash) == 4) {
938 const char *hvname = HvNAME(cstash); assert(hvname);
939 if (strBEGINs(hvname, "CORE")
941 S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
947 else candidate = *gvp;
950 if (SvTYPE(candidate) != SVt_PVGV)
951 gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
952 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
954 * Found real method, cache method in topgv if:
955 * 1. topgv has no synonyms (else inheritance crosses wires)
956 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
958 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
959 CV *old_cv = GvCV(topgv);
960 SvREFCNT_dec(old_cv);
961 SvREFCNT_inc_simple_void_NN(cand_cv);
962 GvCV_set(topgv, cand_cv);
963 GvCVGEN(topgv) = topgen_cmp;
969 /* Check UNIVERSAL without caching */
970 if((level == 0 || level == -1) && !(flags & GV_NOUNIVERSAL)) {
971 candidate = gv_fetchmeth_internal(NULL, meth, name, len, 1,
974 cand_cv = GvCV(candidate);
975 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
976 CV *old_cv = GvCV(topgv);
977 SvREFCNT_dec(old_cv);
978 SvREFCNT_inc_simple_void_NN(cand_cv);
979 GvCV_set(topgv, cand_cv);
980 GvCVGEN(topgv) = topgen_cmp;
986 if (topgv && GvREFCNT(topgv) == 1 && !(flags & GV_NOUNIVERSAL)) {
987 /* cache the fact that the method is not defined */
988 GvCVGEN(topgv) = topgen_cmp;
995 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
997 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
998 return gv_fetchmeth_internal(stash, NULL, name, len, level, flags);
1002 =for apidoc gv_fetchmeth_autoload
1004 This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
1007 =for apidoc gv_fetchmeth_sv_autoload
1009 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
1010 of an SV instead of a string/length pair.
1016 Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
1020 PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
1021 namepv = SvPV(namesv, namelen);
1024 return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
1028 =for apidoc gv_fetchmeth_pv_autoload
1030 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
1031 instead of a string/length pair.
1037 Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
1039 PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
1040 return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
1044 =for apidoc gv_fetchmeth_pvn_autoload
1046 Same as C<gv_fetchmeth_pvn()>, but looks for autoloaded subroutines too.
1047 Returns a glob for the subroutine.
1049 For an autoloaded subroutine without a GV, will create a GV even
1050 if C<level < 0>. For an autoloaded subroutine without a stub, C<GvCV()>
1051 of the result may be zero.
1053 Currently, the only significant value for C<flags> is C<SVf_UTF8>.
1059 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
1061 GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
1063 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
1070 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
1071 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1073 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
1076 if (!(CvROOT(cv) || CvXSUB(cv)))
1078 /* Have an autoload */
1079 if (level < 0) /* Cannot do without a stub */
1080 gv_fetchmeth_pvn(stash, name, len, 0, flags);
1081 gvp = (GV**)hv_fetch(stash, name,
1082 (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
1091 =for apidoc gv_fetchmethod_autoload
1093 Returns the glob which contains the subroutine to call to invoke the method
1094 on the C<stash>. In fact in the presence of autoloading this may be the
1095 glob for "AUTOLOAD". In this case the corresponding variable C<$AUTOLOAD> is
1098 The third parameter of C<gv_fetchmethod_autoload> determines whether
1099 AUTOLOAD lookup is performed if the given method is not present: non-zero
1100 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
1101 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
1102 with a non-zero C<autoload> parameter.
1104 These functions grant C<"SUPER"> token
1105 as a prefix of the method name. Note
1106 that if you want to keep the returned glob for a long time, you need to
1107 check for it being "AUTOLOAD", since at the later time the call may load a
1108 different subroutine due to C<$AUTOLOAD> changing its value. Use the glob
1109 created as a side effect to do this.
1111 These functions have the same side-effects as C<gv_fetchmeth> with
1112 C<level==0>. The warning against passing the GV returned by
1113 C<gv_fetchmeth> to C<call_sv> applies equally to these functions.
1119 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
1121 PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
1123 return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
1127 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
1131 PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
1132 namepv = SvPV(namesv, namelen);
1135 return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
1139 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
1141 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
1142 return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
1146 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
1148 const char * const origname = name;
1149 const char * const name_end = name + len;
1150 const char *last_separator = NULL;
1153 SV *const error_report = MUTABLE_SV(stash);
1154 const U32 autoload = flags & GV_AUTOLOAD;
1155 const U32 do_croak = flags & GV_CROAK;
1156 const U32 is_utf8 = flags & SVf_UTF8;
1158 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
1160 if (SvTYPE(stash) < SVt_PVHV)
1163 /* The only way stash can become NULL later on is if last_separator is set,
1164 which in turn means that there is no need for a SVt_PVHV case
1165 the error reporting code. */
1169 /* check if the method name is fully qualified or
1170 * not, and separate the package name from the actual
1173 * leaves last_separator pointing to the beginning of the
1174 * last package separator (either ' or ::) or 0
1175 * if none was found.
1177 * leaves name pointing at the beginning of the
1180 const char *name_cursor = name;
1181 const char * const name_em1 = name_end - 1; /* name_end minus 1 */
1182 for (name_cursor = name; name_cursor < name_end ; name_cursor++) {
1183 if (*name_cursor == '\'') {
1184 last_separator = name_cursor;
1185 name = name_cursor + 1;
1187 else if (name_cursor < name_em1 && *name_cursor == ':' && name_cursor[1] == ':') {
1188 last_separator = name_cursor++;
1189 name = name_cursor + 1;
1194 /* did we find a separator? */
1195 if (last_separator) {
1196 STRLEN sep_len= last_separator - origname;
1197 if ( memEQs(origname, sep_len, "SUPER")) {
1198 /* ->SUPER::method should really be looked up in original stash */
1199 stash = CopSTASH(PL_curcop);
1201 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
1202 origname, HvENAME_get(stash), name) );
1204 else if ( sep_len >= 7 &&
1205 strBEGINs(last_separator - 7, "::SUPER")) {
1206 /* don't autovifify if ->NoSuchStash::SUPER::method */
1207 stash = gv_stashpvn(origname, sep_len - 7, is_utf8);
1208 if (stash) flags |= GV_SUPER;
1211 /* don't autovifify if ->NoSuchStash::method */
1212 stash = gv_stashpvn(origname, sep_len, is_utf8);
1217 gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
1219 /* This is the special case that exempts Foo->import and
1220 Foo->unimport from being an error even if there's no
1221 import/unimport subroutine */
1222 if (strEQ(name,"import") || strEQ(name,"unimport")) {
1223 gv = (GV*)sv_2mortal((SV*)newCONSTSUB_flags(NULL,
1225 } else if (autoload)
1226 gv = gv_autoload_pvn(
1227 ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags
1229 if (!gv && do_croak) {
1230 /* Right now this is exclusively for the benefit of S_method_common
1233 /* If we can't find an IO::File method, it might be a call on
1234 * a filehandle. If IO:File has not been loaded, try to
1235 * require it first instead of croaking */
1236 const char *stash_name = HvNAME_get(stash);
1237 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1238 && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1239 STR_WITH_LEN("IO/File.pm"), 0,
1240 HV_FETCH_ISEXISTS, NULL, 0)
1242 require_pv("IO/File.pm");
1243 gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
1248 "Can't locate object method %" UTF8f_QUOTEDPREFIX ""
1249 " via package %" HEKf_QUOTEDPREFIX,
1250 UTF8fARG(is_utf8, name_end - name, name),
1251 HEKfARG(HvNAME_HEK(stash)));
1256 if (last_separator) {
1257 packnamesv = newSVpvn_flags(origname, last_separator - origname,
1258 SVs_TEMP | is_utf8);
1260 packnamesv = error_report;
1264 "Can't locate object method %" UTF8f_QUOTEDPREFIX ""
1265 " via package %" SVf_QUOTEDPREFIX ""
1266 " (perhaps you forgot to load %" SVf_QUOTEDPREFIX "?)",
1267 UTF8fARG(is_utf8, name_end - name, name),
1268 SVfARG(packnamesv), SVfARG(packnamesv));
1272 else if (autoload) {
1273 CV* const cv = GvCV(gv);
1274 if (!CvROOT(cv) && !CvXSUB(cv)) {
1278 if (CvANON(cv) || CvLEXICAL(cv))
1282 if (GvCV(stubgv) != cv) /* orphaned import */
1285 autogv = gv_autoload_pvn(GvSTASH(stubgv),
1286 GvNAME(stubgv), GvNAMELEN(stubgv),
1287 GV_AUTOLOAD_ISMETHOD
1288 | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1299 =for apidoc gv_autoload_pv
1300 =for apidoc_item gv_autoload_pvn
1301 =for apidoc_item gv_autoload_sv
1303 These each search for an C<AUTOLOAD> method, returning NULL if not found, or
1304 else returning a pointer to its GV, while setting the package
1305 L<C<$AUTOLOAD>|perlobj/AUTOLOAD> variable to C<name> (fully qualified). Also,
1306 if found and the GV's CV is an XSUB, the CV's PV will be set to C<name>, and
1307 its stash will be set to the stash of the GV.
1309 Searching is done in L<C<MRO> order|perlmroapi>, as specified in
1310 L</C<gv_fetchmeth>>, beginning with C<stash> if it isn't NULL.
1312 The forms differ only in how C<name> is specified.
1314 In C<gv_autoload_pv>, C<namepv> is a C language NUL-terminated string.
1316 In C<gv_autoload_pvn>, C<name> points to the first byte of the name, and an
1317 additional parameter, C<len>, specifies its length in bytes. Hence, C<*name>
1318 may contain embedded-NUL characters.
1320 In C<gv_autoload_sv>, C<*namesv> is an SV, and the name is the PV extracted
1321 from that using L</C<SvPV>>. If the SV is marked as being in UTF-8, the
1322 extracted PV will also be.
1328 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1332 PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1333 namepv = SvPV(namesv, namelen);
1336 return gv_autoload_pvn(stash, namepv, namelen, flags);
1340 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1342 PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1343 return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1347 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1354 SV *packname = NULL;
1355 U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1357 PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1359 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1362 if (SvTYPE(stash) < SVt_PVHV) {
1363 STRLEN packname_len = 0;
1364 const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1365 packname = newSVpvn_flags(packname_ptr, packname_len,
1366 SVs_TEMP | SvUTF8(stash));
1370 packname = newSVhek_mortal(HvNAME_HEK(stash));
1371 if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
1373 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE,
1374 is_utf8 | (flags & GV_SUPER))))
1378 if (!(CvROOT(cv) || CvXSUB(cv)))
1382 * Inheriting AUTOLOAD for non-methods no longer works
1385 !(flags & GV_AUTOLOAD_ISMETHOD)
1386 && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1388 Perl_croak(aTHX_ "Use of inherited AUTOLOAD for non-method %" SVf
1389 "::%" UTF8f "() is no longer allowed",
1391 UTF8fARG(is_utf8, len, name));
1394 /* Instead of forcing the XSUB to do another lookup for $AUTOLOAD
1395 * and split that value on the last '::', pass along the same data
1396 * via the SvPVX field in the CV, and the stash in CvSTASH.
1398 * Due to an unfortunate accident of history, the SvPVX field
1399 * serves two purposes. It is also used for the subroutine's
1400 * prototype. Since SvPVX has been documented as returning the sub
1401 * name for a long time, but not as returning the prototype, we have to
1402 * preserve the SvPVX AUTOLOAD behaviour and put the prototype
1405 * We put the prototype in the same allocated buffer, but after
1406 * the sub name. The SvPOK flag indicates the presence of a proto-
1407 * type. The CvAUTOLOAD flag indicates the presence of a sub name.
1408 * If both flags are on, then SvLEN is used to indicate the end of
1409 * the prototype (artificially lower than what is actually allo-
1410 * cated), at the risk of having to reallocate a few bytes unneces-
1411 * sarily--but that should happen very rarely, if ever.
1413 * We use SvUTF8 for both prototypes and sub names, so if one is
1414 * UTF8, the other must be upgraded.
1416 CvSTASH_set(cv, stash);
1417 if (SvPOK(cv)) { /* Ouch! */
1418 SV * const tmpsv = newSVpvn_flags(name, len, is_utf8);
1420 const char *proto = CvPROTO(cv);
1423 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
1424 ulen = SvCUR(tmpsv);
1425 SvCUR_set(tmpsv, SvCUR(tmpsv) + 1); /* include null in string */
1427 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
1429 SvTEMP_on(tmpsv); /* Allow theft */
1430 sv_setsv_nomg((SV *)cv, tmpsv);
1432 SvREFCNT_dec_NN(tmpsv);
1433 SvLEN_set(cv, SvCUR(cv) + 1);
1434 SvCUR_set(cv, ulen);
1437 sv_setpvn((SV *)cv, name, len);
1441 else SvUTF8_off(cv);
1447 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1448 * The subroutine's original name may not be "AUTOLOAD", so we don't
1449 * use that, but for lack of anything better we will use the sub's
1450 * original package to look up $AUTOLOAD.
1452 varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv));
1453 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1457 gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1458 #ifdef PERL_DONT_CREATE_GVSV
1459 GvSV(vargv) = newSV_type(SVt_NULL);
1463 varsv = GvSVn(vargv);
1464 SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
1465 /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
1466 sv_setsv(varsv, packname);
1467 sv_catpvs(varsv, "::");
1468 /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1469 tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
1472 SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
1480 /* require_tie_mod() internal routine for requiring a module
1481 * that implements the logic of automatic ties like %! and %-
1482 * It loads the module and then calls the _tie_it subroutine
1483 * with the passed gv as an argument.
1485 * The "gv" parameter should be the glob.
1486 * "varname" holds the 1-char name of the var, used for error messages.
1487 * "namesv" holds the module name. Its refcount will be decremented.
1488 * "flags": if flag & 1 then save the scalar before loading.
1489 * For the protection of $! to work (it is set by this routine)
1490 * the sv slot must already be magicalized.
1493 S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name,
1494 STRLEN len, const U32 flags)
1496 const SV * const target = varname == '[' ? GvSV(gv) : (SV *)GvHV(gv);
1498 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1500 /* If it is not tied */
1501 if (!target || !SvRMAGICAL(target)
1503 varname == '[' ? PERL_MAGIC_tiedscalar : PERL_MAGIC_tied))
1509 PUSHSTACKi(PERLSI_MAGIC);
1512 #define GET_HV_FETCH_TIE_FUNC \
1513 ( (gvp = (GV **)hv_fetchs(stash, "_tie_it", 0)) \
1515 && ( (isGV(*gvp) && GvCV(*gvp)) \
1516 || (SvROK(*gvp) && SvTYPE(SvRV(*gvp)) == SVt_PVCV) ) \
1519 /* Load the module if it is not loaded. */
1520 if (!(stash = gv_stashpvn(name, len, 0))
1521 || ! GET_HV_FETCH_TIE_FUNC)
1523 SV * const module = newSVpvn(name, len);
1524 const char type = varname == '[' ? '$' : '%';
1527 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1528 assert(sp == PL_stack_sp);
1529 stash = gv_stashpvn(name, len, 0);
1531 Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available",
1532 type, varname, name);
1533 else if (! GET_HV_FETCH_TIE_FUNC)
1534 Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it",
1535 type, varname, name);
1537 /* Now call the tie function. It should be in *gvp. */
1538 assert(gvp); assert(*gvp);
1542 call_sv((SV *)*gvp, G_VOID|G_DISCARD);
1548 /* add a require_tie_mod_s - the _s suffix is similar to pvs type suffixes,
1549 * IOW it means we do STR_WITH_LEN() ourselves and the user should pass in
1550 * a true string WITHOUT a len.
1552 #define require_tie_mod_s(gv, varname, name, flags) \
1553 S_require_tie_mod(aTHX_ gv, varname, STR_WITH_LEN(name), flags)
1556 =for apidoc gv_stashpv
1558 Returns a pointer to the stash for a specified package. Uses C<strlen> to
1559 determine the length of C<name>, then calls C<gv_stashpvn()>.
1565 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1567 PERL_ARGS_ASSERT_GV_STASHPV;
1568 return gv_stashpvn(name, strlen(name), create);
1572 =for apidoc gv_stashpvn
1574 Returns a pointer to the stash for a specified package. The C<namelen>
1575 parameter indicates the length of the C<name>, in bytes. C<flags> is passed
1576 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1577 created if it does not already exist. If the package does not exist and
1578 C<flags> is 0 (or any other setting that does not create packages) then C<NULL>
1581 Flags may be one of:
1583 GV_ADD Create and initialize the package if doesn't
1585 GV_NOADD_NOINIT Don't create the package,
1586 GV_ADDMG GV_ADD iff the GV is magical
1587 GV_NOINIT GV_ADD, but don't initialize
1588 GV_NOEXPAND Don't expand SvOK() entries to PVGV
1589 SVf_UTF8 The name is in UTF-8
1591 The most important of which are probably C<GV_ADD> and C<SVf_UTF8>.
1593 Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly
1594 recommended for performance reasons.
1596 =for apidoc Amnh||GV_ADD
1597 =for apidoc Amnh||GV_NOADD_NOINIT
1598 =for apidoc Amnh||GV_NOINIT
1599 =for apidoc Amnh||GV_NOEXPAND
1600 =for apidoc Amnh||GV_ADDMG
1601 =for apidoc Amnh||SVf_UTF8
1607 gv_stashpvn_internal
1609 Perform the internal bits of gv_stashsvpvn_cached. You could think of this
1610 as being one half of the logic. Not to be called except from gv_stashsvpvn_cached().
1614 PERL_STATIC_INLINE HV*
1615 S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags)
1621 U32 tmplen = namelen + 2;
1623 PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL;
1625 if (tmplen <= sizeof smallbuf)
1628 Newx(tmpbuf, tmplen, char);
1629 Copy(name, tmpbuf, namelen, char);
1630 tmpbuf[namelen] = ':';
1631 tmpbuf[namelen+1] = ':';
1632 tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1633 if (tmpbuf != smallbuf)
1635 if (!tmpgv || !isGV_with_GP(tmpgv))
1637 stash = GvHV(tmpgv);
1638 if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1640 if (!HvNAME_get(stash)) {
1641 hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1643 /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1644 /* If the containing stash has multiple effective
1645 names, see that this one gets them, too. */
1646 if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1647 mro_package_moved(stash, NULL, tmpgv, 1);
1653 =for apidoc gv_stashsvpvn_cached
1655 Returns a pointer to the stash for a specified package, possibly
1656 cached. Implements both L<perlapi/C<gv_stashpvn>> and
1657 L<perlapi/C<gv_stashsv>>.
1659 Requires one of either C<namesv> or C<namepv> to be non-null.
1661 If the flag C<GV_CACHE_ONLY> is set, return the stash only if found in the
1662 cache; see L<perlapi/C<gv_stashpvn>> for details on the other C<flags>.
1664 Note it is strongly preferred for C<namesv> to be non-null, for performance
1667 =for apidoc Emnh||GV_CACHE_ONLY
1672 #define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \
1673 assert(namesv || name)
1676 Perl_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
1681 PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED;
1683 he = (HE *)hv_common(
1684 PL_stashcache, namesv, name, namelen,
1685 (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0
1692 hv = INT2PTR(HV*, SvIVX(sv));
1693 assert(SvTYPE(hv) == SVt_PVHV);
1696 else if (flags & GV_CACHE_ONLY) return NULL;
1699 if (SvOK(namesv)) { /* prevent double uninit warning */
1701 name = SvPV_const(namesv, len);
1703 flags |= SvUTF8(namesv);
1705 name = ""; namelen = 0;
1708 stash = gv_stashpvn_internal(name, namelen, flags);
1710 if (stash && namelen) {
1711 SV* const ref = newSViv(PTR2IV(stash));
1712 (void)hv_store(PL_stashcache, name,
1713 (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0);
1720 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1722 PERL_ARGS_ASSERT_GV_STASHPVN;
1723 return gv_stashsvpvn_cached(NULL, name, namelen, flags);
1727 =for apidoc gv_stashsv
1729 Returns a pointer to the stash for a specified package. See
1732 Note this interface is strongly preferred over C<gv_stashpvn> for performance
1739 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1741 PERL_ARGS_ASSERT_GV_STASHSV;
1742 return gv_stashsvpvn_cached(sv, NULL, 0, flags);
1745 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 flags, const svtype sv_type) {
1746 PERL_ARGS_ASSERT_GV_FETCHPV;
1747 return gv_fetchpvn_flags(nambeg, strlen(nambeg), flags, sv_type);
1751 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1753 const char * const nambeg =
1754 SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1755 PERL_ARGS_ASSERT_GV_FETCHSV;
1756 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1759 PERL_STATIC_INLINE void
1760 S_gv_magicalize_isa(pTHX_ GV *gv)
1764 PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1768 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1772 /* This function grabs name and tries to split a stash and glob
1773 * from its contents. TODO better description, comments
1775 * If the function returns TRUE and 'name == name_end', then
1776 * 'gv' can be directly returned to the caller of gv_fetchpvn_flags
1778 PERL_STATIC_INLINE bool
1779 S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name,
1780 STRLEN *len, const char *nambeg, STRLEN full_len,
1781 const U32 is_utf8, const I32 add)
1783 char *tmpfullbuf = NULL; /* only malloc one big chunk of memory when the smallbuff is not large enough */
1784 const char *name_cursor;
1785 const char *const name_end = nambeg + full_len;
1786 const char *const name_em1 = name_end - 1;
1787 char smallbuf[64]; /* small buffer to avoid a malloc when possible */
1789 PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
1793 && isIDFIRST_lazy_if_safe(*name + 1, name_end, is_utf8))
1795 /* accidental stringify on a GV? */
1799 for (name_cursor = *name; name_cursor < name_end; name_cursor++) {
1800 if (name_cursor < name_em1 &&
1801 ((*name_cursor == ':' && name_cursor[1] == ':')
1802 || *name_cursor == '\''))
1805 *stash = PL_defstash;
1806 if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */
1809 *len = name_cursor - *name;
1810 if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1813 if (*name_cursor == ':') {
1817 else { /* using ' for package separator */
1818 /* use our pre-allocated buffer when possible to save a malloc */
1820 if ( *len+2 <= sizeof smallbuf)
1823 /* only malloc once if needed */
1824 if (tmpfullbuf == NULL) /* only malloc&free once, a little more than needed */
1825 Newx(tmpfullbuf, full_len+2, char);
1826 tmpbuf = tmpfullbuf;
1828 Copy(*name, tmpbuf, *len, char);
1829 tmpbuf[(*len)++] = ':';
1830 tmpbuf[(*len)++] = ':';
1833 gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add);
1834 *gv = gvp ? *gvp : NULL;
1835 if (!*gv || *gv == (const GV *)&PL_sv_undef) {
1838 /* here we know that *gv && *gv != &PL_sv_undef */
1839 if (SvTYPE(*gv) != SVt_PVGV)
1840 gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
1844 if (!(*stash = GvHV(*gv))) {
1845 *stash = GvHV(*gv) = newHV();
1846 if (!HvNAME_get(*stash)) {
1847 if (GvSTASH(*gv) == PL_defstash && *len == 6
1848 && strBEGINs(*name, "CORE"))
1849 hv_name_sets(*stash, "CORE", 0);
1852 *stash, nambeg, name_cursor-nambeg, is_utf8
1854 /* If the containing stash has multiple effective
1855 names, see that this one gets them, too. */
1856 if (HvAUX(GvSTASH(*gv))->xhv_name_count)
1857 mro_package_moved(*stash, NULL, *gv, 1);
1860 else if (!HvNAME_get(*stash))
1861 hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8);
1864 if (*name_cursor == ':')
1866 *name = name_cursor+1;
1867 if (*name == name_end) {
1869 *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1870 if (SvTYPE(*gv) != SVt_PVGV) {
1871 gv_init_pvn(*gv, PL_defstash, "main::", 6,
1874 MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
1881 *len = name_cursor - *name;
1883 Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
1886 Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
1891 /* Checks if an unqualified name is in the main stash */
1892 PERL_STATIC_INLINE bool
1893 S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
1895 PERL_ARGS_ASSERT_GV_IS_IN_MAIN;
1897 /* If it's an alphanumeric variable */
1898 if ( len && isIDFIRST_lazy_if_safe(name, name + len, is_utf8) ) {
1899 /* Some "normal" variables are always in main::,
1900 * like INC or STDOUT.
1908 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1909 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1910 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1914 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1919 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1920 && name[3] == 'I' && name[4] == 'N')
1924 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1925 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1926 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1930 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1931 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1937 /* *{""}, or a special variable like $@ */
1945 /* This function is called if parse_gv_stash_name() failed to
1946 * find a stash, or if GV_NOTQUAL or an empty name was passed
1947 * to gv_fetchpvn_flags.
1949 * It returns FALSE if the default stash can't be found nor created,
1950 * which might happen during global destruction.
1952 PERL_STATIC_INLINE bool
1953 S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
1954 const U32 is_utf8, const I32 add,
1955 const svtype sv_type)
1957 PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
1959 /* No stash in name, so see how we can default */
1961 if ( gv_is_in_main(name, len, is_utf8) ) {
1962 *stash = PL_defstash;
1965 if (IN_PERL_COMPILETIME) {
1966 *stash = PL_curstash;
1967 if (add && (PL_hints & HINT_STRICT_VARS) &&
1968 sv_type != SVt_PVCV &&
1969 sv_type != SVt_PVGV &&
1970 sv_type != SVt_PVFM &&
1971 sv_type != SVt_PVIO &&
1972 !(len == 1 && sv_type == SVt_PV &&
1973 (*name == 'a' || *name == 'b')) )
1975 GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0);
1976 if (!gvp || *gvp == (const GV *)&PL_sv_undef ||
1977 SvTYPE(*gvp) != SVt_PVGV)
1981 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
1982 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1983 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1985 /* diag_listed_as: Variable "%s" is not imported%s */
1987 aTHX_ packWARN(WARN_MISC),
1988 "Variable \"%c%" UTF8f "\" is not imported",
1989 sv_type == SVt_PVAV ? '@' :
1990 sv_type == SVt_PVHV ? '%' : '$',
1991 UTF8fARG(is_utf8, len, name));
1994 aTHX_ packWARN(WARN_MISC),
1995 "\t(Did you mean &%" UTF8f " instead?)\n",
1996 UTF8fARG(is_utf8, len, name)
2003 /* Use the current op's stash */
2004 *stash = CopSTASH(PL_curcop);
2009 if (add && !PL_in_clean_all) {
2011 qerror(Perl_mess(aTHX_
2012 "Global symbol \"%s%" UTF8f
2013 "\" requires explicit package name (did you forget to "
2014 "declare \"my %s%" UTF8f "\"?)",
2015 (sv_type == SVt_PV ? "$"
2016 : sv_type == SVt_PVAV ? "@"
2017 : sv_type == SVt_PVHV ? "%"
2018 : ""), UTF8fARG(is_utf8, len, name),
2019 (sv_type == SVt_PV ? "$"
2020 : sv_type == SVt_PVAV ? "@"
2021 : sv_type == SVt_PVHV ? "%"
2022 : ""), UTF8fARG(is_utf8, len, name)));
2023 /* To maintain the output of errors after the strict exception
2024 * above, and to keep compat with older releases, rather than
2025 * placing the variables in the pad, we place
2026 * them in the <none>:: stash.
2028 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
2030 /* symbol table under destruction */
2039 if (!SvREFCNT(*stash)) /* symbol table under destruction */
2045 /* gv_magicalize only turns on the SVf_READONLY flag, not SVf_PROTECT. So
2046 redefine SvREADONLY_on for that purpose. We don’t use it later on in
2048 #undef SvREADONLY_on
2049 #define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY)
2051 /* gv_magicalize() is called by gv_fetchpvn_flags when creating
2053 * Note that it does not insert the GV into the stash prior to
2054 * magicalization, which some variables require need in order
2055 * to work (like %+, %-, %!), so callers must take care of
2058 * It returns true if the gv did turn out to be magical one; i.e.,
2059 * if gv_magicalize actually did something.
2061 PERL_STATIC_INLINE bool
2062 S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
2063 const svtype sv_type)
2067 PERL_ARGS_ASSERT_GV_MAGICALIZE;
2069 if (stash != PL_defstash) { /* not the main stash */
2070 /* We only have to check for a few names here: a, b, EXPORT, ISA
2071 and VERSION. All the others apply only to the main stash or to
2072 CORE (which is checked right after this). */
2077 len >= 6 && name[1] == 'X' &&
2078 (memEQs(name, len, "EXPORT")
2079 ||memEQs(name, len, "EXPORT_OK")
2080 ||memEQs(name, len, "EXPORT_FAIL")
2081 ||memEQs(name, len, "EXPORT_TAGS"))
2086 if (memEQs(name, len, "ISA"))
2087 gv_magicalize_isa(gv);
2090 if (memEQs(name, len, "VERSION"))
2094 if (stash == PL_debstash && memEQs(name, len, "args")) {
2095 GvMULTI_on(gv_AVadd(gv));
2100 if (len == 1 && sv_type == SVt_PV)
2109 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
2110 /* Avoid null warning: */
2111 const char * const stashname = HvNAME(stash); assert(stashname);
2112 if (strBEGINs(stashname, "CORE"))
2113 S_maybe_add_coresub(aTHX_ 0, gv, name, len);
2120 /* Nothing else to do.
2121 The compiler will probably turn the switch statement into a
2122 branch table. Make sure we avoid even that small overhead for
2123 the common case of lower case variable names. (On EBCDIC
2124 platforms, we can't just do:
2125 if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) {
2126 because cases like '\027' in the switch statement below are
2127 C1 (non-ASCII) controls on those platforms, so the remapping
2128 would make them larger than 'V')
2135 if (memEQs(name, len, "ARGV")) {
2136 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
2138 else if (memEQs(name, len, "ARGVOUT")) {
2144 len >= 6 && name[1] == 'X' &&
2145 (memEQs(name, len, "EXPORT")
2146 ||memEQs(name, len, "EXPORT_OK")
2147 ||memEQs(name, len, "EXPORT_FAIL")
2148 ||memEQs(name, len, "EXPORT_TAGS"))
2153 if (memEQs(name, len, "ISA")) {
2154 gv_magicalize_isa(gv);
2158 if (memEQs(name, len, "SIG")) {
2161 if (!PL_psig_name) {
2162 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
2163 Newxz(PL_psig_pend, SIG_SIZE, int);
2164 PL_psig_ptr = PL_psig_name + SIG_SIZE;
2166 /* I think that the only way to get here is to re-use an
2167 embedded perl interpreter, where the previous
2168 use didn't clean up fully because
2169 PL_perl_destruct_level was 0. I'm not sure that we
2170 "support" that, in that I suspect in that scenario
2171 there are sufficient other garbage values left in the
2172 interpreter structure that something else will crash
2173 before we get here. I suspect that this is one of
2174 those "doctor, it hurts when I do this" bugs. */
2175 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
2176 Zero(PL_psig_pend, SIG_SIZE, int);
2180 hv_magic(hv, NULL, PERL_MAGIC_sig);
2181 for (i = 1; i < SIG_SIZE; i++) {
2182 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
2184 sv_setsv(*init, &PL_sv_undef);
2189 if (memEQs(name, len, "VERSION"))
2192 case '\003': /* $^CHILD_ERROR_NATIVE */
2193 if (memEQs(name, len, "\003HILD_ERROR_NATIVE"))
2195 /* @{^CAPTURE} %{^CAPTURE} */
2196 if (memEQs(name, len, "\003APTURE")) {
2197 AV* const av = GvAVn(gv);
2198 const Size_t n = *name;
2200 sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
2203 require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
2205 } else /* %{^CAPTURE_ALL} */
2206 if (memEQs(name, len, "\003APTURE_ALL")) {
2207 require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
2210 case '\005': /* $^ENCODING */
2211 if (memEQs(name, len, "\005NCODING"))
2214 case '\007': /* $^GLOBAL_PHASE */
2215 if (memEQs(name, len, "\007LOBAL_PHASE"))
2218 case '\014': /* $^LAST_FH */
2219 if (memEQs(name, len, "\014AST_FH"))
2222 case '\015': /* $^MATCH */
2223 if (memEQs(name, len, "\015ATCH")) {
2224 paren = RX_BUFF_IDX_CARET_FULLMATCH;
2228 case '\017': /* $^OPEN */
2229 if (memEQs(name, len, "\017PEN"))
2232 case '\020': /* $^PREMATCH $^POSTMATCH */
2233 if (memEQs(name, len, "\020REMATCH")) {
2234 paren = RX_BUFF_IDX_CARET_PREMATCH;
2237 if (memEQs(name, len, "\020OSTMATCH")) {
2238 paren = RX_BUFF_IDX_CARET_POSTMATCH;
2243 if (memEQs(name, len, "\023AFE_LOCALES"))
2246 case '\024': /* ${^TAINT} */
2247 if (memEQs(name, len, "\024AINT"))
2250 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
2251 if (memEQs(name, len, "\025NICODE"))
2253 if (memEQs(name, len, "\025TF8LOCALE"))
2255 if (memEQs(name, len, "\025TF8CACHE"))
2258 case '\027': /* $^WARNING_BITS */
2259 if (memEQs(name, len, "\027ARNING_BITS"))
2262 else if (memEQs(name, len, "\027IN32_SLOPPY_STAT"))
2276 /* Ensures that we have an all-digit variable, ${"1foo"} fails
2279 if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX)
2281 /* XXX why are we using a SSize_t? */
2282 paren = (SSize_t)(I32)uv;
2288 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
2289 be case '\0' in this switch statement (ie a default case) */
2292 paren = RX_BUFF_IDX_FULLMATCH;
2295 paren = RX_BUFF_IDX_PREMATCH;
2298 paren = RX_BUFF_IDX_POSTMATCH;
2300 #ifdef PERL_SAWAMPERSAND
2302 sv_type == SVt_PVAV ||
2303 sv_type == SVt_PVHV ||
2304 sv_type == SVt_PVCV ||
2305 sv_type == SVt_PVFM ||
2307 )) { PL_sawampersand |=
2311 ? SAWAMPERSAND_MIDDLE
2312 : SAWAMPERSAND_RIGHT;
2325 paren = *name - '0';
2328 /* Flag the capture variables with a NULL mg_ptr
2329 Use mg_len for the array index to lookup. */
2330 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
2334 sv_setpv(GvSVn(gv),PL_chopset);
2338 #ifdef COMPLEX_STATUS
2339 SvUPGRADE(GvSVn(gv), SVt_PVLV);
2345 /* If %! has been used, automatically load Errno.pm. */
2347 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2349 /* magicalization must be done before require_tie_mod_s is called */
2350 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2351 require_tie_mod_s(gv, '!', "Errno", 1);
2354 case '-': /* $-, %-, @- */
2355 case '+': /* $+, %+, @+ */
2356 GvMULTI_on(gv); /* no used once warnings here */
2358 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2360 SvREADONLY_on(GvSVn(gv));
2363 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2364 require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture",0);
2367 AV* const av = GvAVn(gv);
2368 const Size_t n = *name;
2370 sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
2376 if (sv_type == SVt_PV)
2377 /* diag_listed_as: $* is no longer supported as of Perl 5.30 */
2378 Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name);
2380 case '\010': /* $^H */
2382 HV *const hv = GvHVn(gv);
2383 hv_magic(hv, NULL, PERL_MAGIC_hints);
2386 case '\023': /* $^S */
2388 SvREADONLY_on(GvSVn(gv));
2405 case '\001': /* $^A */
2406 case '\003': /* $^C */
2407 case '\004': /* $^D */
2408 case '\005': /* $^E */
2409 case '\006': /* $^F */
2410 case '\011': /* $^I, NOT \t in EBCDIC */
2411 case '\016': /* $^N */
2412 case '\017': /* $^O */
2413 case '\020': /* $^P */
2414 case '\024': /* $^T */
2415 case '\027': /* $^W */
2417 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2420 case '\014': /* $^L */
2421 sv_setpvs(GvSVn(gv),"\f");
2424 sv_setpvs(GvSVn(gv),"\034");
2428 SV * const sv = GvSV(gv);
2429 if (!sv_derived_from(PL_patchlevel, "version"))
2430 upg_version(PL_patchlevel, TRUE);
2431 GvSV(gv) = vnumify(PL_patchlevel);
2432 SvREADONLY_on(GvSV(gv));
2436 case '\026': /* $^V */
2438 SV * const sv = GvSV(gv);
2439 GvSV(gv) = new_version(PL_patchlevel);
2440 SvREADONLY_on(GvSV(gv));
2446 if (sv_type == SVt_PV)
2452 /* Return true if we actually did something. */
2453 return GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv)
2455 SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv))
2460 /* If we do ever start using this later on in the file, we need to make
2461 sure we don’t accidentally use the wrong definition. */
2462 #undef SvREADONLY_on
2464 /* This function is called when the stash already holds the GV of the magic
2465 * variable we're looking for, but we need to check that it has the correct
2466 * kind of magic. For example, if someone first uses $! and then %!, the
2467 * latter would end up here, and we add the Errno tie to the HASH slot of
2470 PERL_STATIC_INLINE void
2471 S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
2473 PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV;
2475 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
2477 require_tie_mod_s(gv, '!', "Errno", 1);
2478 else if (*name == '-' || *name == '+')
2479 require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture", 0);
2480 } else if (sv_type == SVt_PV) {
2481 if (*name == '*' || *name == '#') {
2482 /* diag_listed_as: $* is no longer supported as of Perl 5.30 */
2483 Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name);
2486 if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
2488 #ifdef PERL_SAWAMPERSAND
2490 PL_sawampersand |= SAWAMPERSAND_LEFT;
2494 PL_sawampersand |= SAWAMPERSAND_MIDDLE;
2498 PL_sawampersand |= SAWAMPERSAND_RIGHT;
2507 =for apidoc gv_fetchpv
2508 =for apidoc_item |GV *|gv_fetchpvn|const char * nambeg|STRLEN full_len|I32 flags|const svtype sv_type
2509 =for apidoc_item ||gv_fetchpvn_flags
2510 =for apidoc_item |GV *|gv_fetchpvs|"name"|I32 flags|const svtype sv_type
2511 =for apidoc_item ||gv_fetchsv
2512 =for apidoc_item |GV *|gv_fetchsv_nomg|SV *name|I32 flags|const svtype sv_type
2514 These all return the GV of type C<sv_type> whose name is given by the inputs,
2515 or NULL if no GV of that name and type could be found. See L<perlguts/Stashes
2518 The only differences are how the input name is specified, and if 'get' magic is
2519 normally used in getting that name.
2521 Don't be fooled by the fact that only one form has C<flags> in its name. They
2522 all have a C<flags> parameter in fact, and all the flag bits have the same
2525 If any of the flags C<GV_ADD>, C<GV_ADDMG>, C<GV_ADDWARN>, C<GV_ADDMULTI>, or
2526 C<GV_NOINIT> is set, a GV is created if none already exists for the input name
2527 and type. However, C<GV_ADDMG> will only do the creation for magical GV's.
2528 For all of these flags except C<GV_NOINIT>, C<L</gv_init_pvn>> is called after
2529 the addition. C<GV_ADDWARN> is used when the caller expects that adding won't
2530 be necessary because the symbol should already exist; but if not, add it
2531 anyway, with a warning that it was unexpectedly absent. The C<GV_ADDMULTI>
2532 flag means to pretend that the GV has been seen before (I<i.e.>, suppress "Used
2535 The flag C<GV_NOADD_NOINIT> causes C<L</gv_init_pvn>> not be to called if the
2536 GV existed but isn't PVGV.
2538 If the C<SVf_UTF8> bit is set, the name is treated as being encoded in UTF-8;
2539 otherwise the name won't be considered to be UTF-8 in the C<pv>-named forms,
2540 and the UTF-8ness of the underlying SVs will be used in the C<sv> forms.
2542 If the flag C<GV_NOTQUAL> is set, the caller warrants that the input name is a
2543 plain symbol name, not qualified with a package, otherwise the name is checked
2544 for being a qualified one.
2546 In C<gv_fetchpv>, C<nambeg> is a C string, NUL-terminated with no intermediate
2549 In C<gv_fetchpvs>, C<name> is a literal C string, hence is enclosed in
2552 C<gv_fetchpvn> and C<gv_fetchpvn_flags> are identical. In these, <nambeg> is
2553 a Perl string whose byte length is given by C<full_len>, and may contain
2556 In C<gv_fetchsv> and C<gv_fetchsv_nomg>, the name is extracted from the PV of
2557 the input C<name> SV. The only difference between these two forms is that
2558 'get' magic is normally done on C<name> in C<gv_fetchsv>, and always skipped
2559 with C<gv_fetchsv_nomg>. Including C<GV_NO_SVGMAGIC> in the C<flags> parameter
2560 to C<gv_fetchsv> makes it behave identically to C<gv_fetchsv_nomg>.
2562 =for apidoc Amnh||GV_ADD
2563 =for apidoc Amnh||GV_ADDMG
2564 =for apidoc Amnh||GV_ADDMULTI
2565 =for apidoc Amnh||GV_ADDWARN
2566 =for apidoc Amnh||GV_NOINIT
2567 =for apidoc Amnh||GV_NOADD_NOINIT
2568 =for apidoc Amnh||GV_NOTQUAL
2569 =for apidoc Amnh||GV_NO_SVGMAGIC
2570 =for apidoc Amnh||SVf_UTF8
2576 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
2577 const svtype sv_type)
2579 const char *name = nambeg;
2584 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
2585 const I32 no_expand = flags & GV_NOEXPAND;
2586 const I32 add = flags & ~GV_NOADD_MASK;
2587 const U32 is_utf8 = flags & SVf_UTF8;
2588 bool addmg = cBOOL(flags & GV_ADDMG);
2589 const char *const name_end = nambeg + full_len;
2592 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
2594 /* If we have GV_NOTQUAL, the caller promised that
2595 * there is no stash, so we can skip the check.
2596 * Similarly if full_len is 0, since then we're
2597 * dealing with something like *{""} or ""->foo()
2599 if ((flags & GV_NOTQUAL) || !full_len) {
2602 else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) {
2603 if (name == name_end) return gv;
2609 if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) {
2613 /* By this point we should have a stash and a name */
2614 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add);
2615 if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
2616 if (addmg) gv = (GV *)newSV_type(SVt_NULL); /* tentatively */
2619 else gv = *gvp, addmg = 0;
2620 /* From this point on, addmg means gv has not been inserted in the
2623 if (SvTYPE(gv) == SVt_PVGV) {
2624 /* The GV already exists, so return it, but check if we need to do
2625 * anything else with it before that.
2628 /* This is the heuristic that handles if a variable triggers the
2629 * 'used only once' warning. If there's already a GV in the stash
2630 * with this name, then we assume that the variable has been used
2631 * before and turn its MULTI flag on.
2632 * It's a heuristic because it can easily be "tricked", like with
2633 * BEGIN { $a = 1; $::{foo} = *a }; () = $foo
2634 * not warning about $main::foo being used just once
2637 gv_init_svtype(gv, sv_type);
2638 /* You reach this path once the typeglob has already been created,
2639 either by the same or a different sigil. If this path didn't
2640 exist, then (say) referencing $! first, and %! second would
2641 mean that %! was not handled correctly. */
2642 if (len == 1 && stash == PL_defstash) {
2643 maybe_multimagic_gv(gv, name, sv_type);
2645 else if (sv_type == SVt_PVAV
2646 && memEQs(name, len, "ISA")
2647 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
2648 gv_magicalize_isa(gv);
2651 } else if (no_init) {
2655 /* If GV_NOEXPAND is true and what we got off the stash is a ref,
2656 * don't expand it to a glob. This is an optimization so that things
2657 * copying constants over, like Exporter, don't have to be rewritten
2658 * to take into account that you can store more than just globs in
2661 else if (no_expand && SvROK(gv)) {
2666 /* Adding a new symbol.
2667 Unless of course there was already something non-GV here, in which case
2668 we want to behave as if there was always a GV here, containing some sort
2670 Otherwise we run the risk of creating things like GvIO, which can cause
2671 subtle bugs. eg the one that tripped up SQL::Translator */
2673 faking_it = SvOK(gv);
2675 if (add & GV_ADDWARN)
2676 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2677 "Had to create %" UTF8f " unexpectedly",
2678 UTF8fARG(is_utf8, name_end-nambeg, nambeg));
2679 gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
2682 && isIDFIRST_lazy_if_safe(name, name + full_len, is_utf8)
2683 && !ckWARN(WARN_ONCE) )
2688 /* set up magic where warranted */
2689 if ( gv_magicalize(gv, stash, name, len, sv_type) ) {
2692 /* gv_magicalize magicalised this gv, so we want it
2693 * stored in the symtab.
2694 * Effectively the caller is asking, ‘Does this gv exist?’
2695 * And we respond, ‘Er, *now* it does!’
2697 (void)hv_store(stash,name,len,(SV *)gv,0);
2701 /* The temporary GV created above */
2702 SvREFCNT_dec_NN(gv);
2706 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2711 =for apidoc gv_efullname3
2712 =for apidoc_item gv_efullname4
2713 =for apidoc_item gv_fullname3
2714 =for apidoc_item gv_fullname4
2716 Place the full package name of C<gv> into C<sv>. The C<gv_e*> forms return
2717 instead the effective package name (see L</HvENAME>).
2719 If C<prefix> is non-NULL, it is considered to be a C language NUL-terminated
2720 string, and the stored name will be prefaced with it.
2722 The other difference between the functions is that the C<*4> forms have an
2723 extra parameter, C<keepmain>. If C<true> an initial C<main::> in the name is
2724 kept; if C<false> it is stripped. With the C<*3> forms, it is always kept.
2730 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2733 const HV * const hv = GvSTASH(gv);
2735 PERL_ARGS_ASSERT_GV_FULLNAME4;
2737 sv_setpv(sv, prefix ? prefix : "");
2739 if (hv && (name = HvNAME(hv))) {
2740 const STRLEN len = HvNAMELEN(hv);
2741 if (keepmain || ! memBEGINs(name, len, "main")) {
2742 sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2746 else sv_catpvs(sv,"__ANON__::");
2747 sv_catsv(sv,newSVhek_mortal(GvNAME_HEK(gv)));
2751 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2753 const GV * const egv = GvEGVx(gv);
2755 PERL_ARGS_ASSERT_GV_EFULLNAME4;
2757 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2761 /* recursively scan a stash and any nested stashes looking for entries
2762 * that need the "only used once" warning raised
2766 Perl_gv_check(pTHX_ HV *stash)
2770 PERL_ARGS_ASSERT_GV_CHECK;
2772 if (!HvHasAUX(stash))
2775 assert(HvARRAY(stash));
2777 /* mark stash is being scanned, to avoid recursing */
2778 HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH;
2779 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2781 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2784 STRLEN keylen = HeKLEN(entry);
2785 const char * const key = HeKEY(entry);
2787 if (keylen >= 2 && key[keylen-2] == ':' && key[keylen-1] == ':' &&
2788 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2790 if (hv != PL_defstash && hv != stash
2792 && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH))
2794 gv_check(hv); /* nested package */
2796 else if ( HeKLEN(entry) != 0
2797 && *HeKEY(entry) != '_'
2798 && isIDFIRST_lazy_if_safe(HeKEY(entry),
2799 HeKEY(entry) + HeKLEN(entry),
2803 gv = MUTABLE_GV(HeVAL(entry));
2804 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2807 CopLINE_set(PL_curcop, GvLINE(gv));
2809 CopFILE(PL_curcop) = (char *)file; /* set for warning */
2811 CopFILEGV(PL_curcop)
2812 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2814 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2815 "Name \"%" HEKf "::%" HEKf
2816 "\" used only once: possible typo",
2817 HEKfARG(HvNAME_HEK(stash)),
2818 HEKfARG(GvNAME_HEK(gv)));
2822 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH;
2826 =for apidoc newGVgen
2827 =for apidoc_item newGVgen_flags
2829 Create a new, guaranteed to be unique, GV in the package given by the
2830 NUL-terminated C language string C<pack>, and return a pointer to it.
2832 For C<newGVgen> or if C<flags> in C<newGVgen_flags> is 0, C<pack> is to be
2833 considered to be encoded in Latin-1. The only other legal C<flags> value is
2834 C<SVf_UTF8>, which indicates C<pack> is to be considered to be encoded in
2841 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2843 PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2844 assert(!(flags & ~SVf_UTF8));
2846 return gv_fetchpv(Perl_form(aTHX_ "%" UTF8f "::_GEN_%ld",
2847 UTF8fARG(flags, strlen(pack), pack),
2852 /* hopefully this is only called on local symbol table entries */
2855 Perl_gp_ref(pTHX_ GP *gp)
2862 /* If the GP they asked for a reference to contains
2863 a method cache entry, clear it first, so that we
2864 don't infect them with our cached entry */
2865 SvREFCNT_dec_NN(gp->gp_cv);
2874 Perl_gp_free(pTHX_ GV *gv)
2878 bool in_global_destruction = PL_phase == PERL_PHASE_DESTRUCT;
2880 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2882 if (gp->gp_refcnt == 0) {
2883 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2884 "Attempt to free unreferenced glob pointers"
2885 pTHX__FORMAT pTHX__VALUE);
2888 if (gp->gp_refcnt > 1) {
2890 if (gp->gp_egv == gv)
2898 /* Copy and null out all the glob slots, so destructors do not see
2900 HEK * const file_hek = gp->gp_file_hek;
2901 SV * sv = gp->gp_sv;
2902 AV * av = gp->gp_av;
2903 HV * hv = gp->gp_hv;
2904 IO * io = gp->gp_io;
2905 CV * cv = gp->gp_cv;
2906 CV * form = gp->gp_form;
2910 gp->gp_file_hek = NULL;
2919 unshare_hek(file_hek);
2921 /* Storing the SV on the temps stack (instead of freeing it immediately)
2922 is an admitted bodge that attempt to compensate for the lack of
2923 reference counting on the stack. The motivation is that typeglob syntax
2924 is extremely short hence programs such as '$a += (*a = 2)' are often
2925 found randomly by researchers running fuzzers. Previously these
2926 programs would trigger errors, that the researchers would
2927 (legitimately) report, and then we would spend time figuring out that
2928 the cause was "stack not reference counted" and so not a dangerous
2929 security hole. This consumed a lot of researcher time, our time, and
2930 prevents "interesting" security holes being uncovered.
2932 Typeglob assignment is rarely used in performance critical production
2933 code, so we aren't causing much slowdown by doing extra work here.
2935 In turn, the need to check for SvOBJECT (and references to objects) is
2936 because we have regression tests that rely on timely destruction that
2937 happens *within this while loop* to demonstrate behaviour, and
2938 potentially there is also *working* code in the wild that relies on
2941 And we need to avoid doing this in global destruction else we can end
2942 up with "Attempt to free temp prematurely ... Unbalanced string table
2945 Hence the whole thing is a heuristic intended to mitigate against
2946 simple problems likely found by fuzzers but never written by humans,
2947 whilst leaving working code unchanged. */
2950 if (SvREFCNT(sv) > 1 || SvOBJECT(sv) || UNLIKELY(in_global_destruction)) {
2951 SvREFCNT_dec_NN(sv);
2953 } else if (SvROK(sv) && (referant = SvRV(sv))
2954 && (SvREFCNT(referant) > 1 || SvOBJECT(referant))) {
2955 SvREFCNT_dec_NN(sv);
2962 if (SvREFCNT(av) > 1 || SvOBJECT(av) || UNLIKELY(in_global_destruction)) {
2963 SvREFCNT_dec_NN(av);
2969 /* FIXME - another reference loop GV -> symtab -> GV ?
2970 Somehow gp->gp_hv can end up pointing at freed garbage. */
2971 if (hv && SvTYPE(hv) == SVt_PVHV) {
2972 const HEK *hvname_hek = HvNAME_HEK(hv);
2973 if (PL_stashcache && hvname_hek) {
2974 DEBUG_o(Perl_deb(aTHX_
2975 "gp_free clearing PL_stashcache for '%" HEKf "'\n",
2976 HEKfARG(hvname_hek)));
2977 (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
2979 if (SvREFCNT(hv) > 1 || SvOBJECT(hv) || UNLIKELY(in_global_destruction)) {
2980 SvREFCNT_dec_NN(hv);
2986 if (io && SvREFCNT(io) == 1 && IoIFP(io)
2987 && (IoTYPE(io) == IoTYPE_WRONLY ||
2988 IoTYPE(io) == IoTYPE_RDWR ||
2989 IoTYPE(io) == IoTYPE_APPEND)
2990 && ckWARN_d(WARN_IO)
2991 && IoIFP(io) != PerlIO_stdin()
2992 && IoIFP(io) != PerlIO_stdout()
2993 && IoIFP(io) != PerlIO_stderr()
2994 && !(IoFLAGS(io) & IOf_FAKE_DIRP))
2995 io_close(io, gv, FALSE, TRUE);
2997 if (SvREFCNT(io) > 1 || SvOBJECT(io) || UNLIKELY(in_global_destruction)) {
2998 SvREFCNT_dec_NN(io);
3005 if (SvREFCNT(cv) > 1 || SvOBJECT(cv) || UNLIKELY(in_global_destruction)) {
3006 SvREFCNT_dec_NN(cv);
3013 if (SvREFCNT(form) > 1 || SvOBJECT(form) || UNLIKELY(in_global_destruction)) {
3014 SvREFCNT_dec_NN(form);
3022 /* We don't strictly need to defer all this to the end, but it's
3023 easiest to do so. The subtle problems we have are
3024 1) any of the actions triggered by the various SvREFCNT_dec()s in
3025 any of the intermediate blocks can cause more items to be added
3026 to the temps stack. So we can't "cache" its state locally
3027 2) We'd have to re-check the "extend by 1?" for each time.
3028 Whereas if we don't NULL out the values that we want to put onto
3029 the save stack until here, we can do it in one go, with one
3032 SSize_t max_ix = PL_tmps_ix + need;
3034 if (max_ix >= PL_tmps_max) {
3035 tmps_grow_p(max_ix);
3039 PL_tmps_stack[++PL_tmps_ix] = sv;
3042 PL_tmps_stack[++PL_tmps_ix] = (SV *) av;
3045 PL_tmps_stack[++PL_tmps_ix] = (SV *) hv;
3048 PL_tmps_stack[++PL_tmps_ix] = (SV *) io;
3051 PL_tmps_stack[++PL_tmps_ix] = (SV *) cv;
3054 PL_tmps_stack[++PL_tmps_ix] = (SV *) form;
3058 /* Possibly reallocated by a destructor */
3061 if (!gp->gp_file_hek
3067 && !gp->gp_form) break;
3069 if (--attempts == 0) {
3071 "panic: gp_free failed to free glob pointer - "
3072 "something is repeatedly re-creating entries"
3077 /* Possibly incremented by a destructor doing glob assignment */
3078 if (gp->gp_refcnt > 1) goto borrowed;
3084 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
3086 AMT * const amtp = (AMT*)mg->mg_ptr;
3087 PERL_UNUSED_ARG(sv);
3089 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
3091 if (amtp && AMT_AMAGIC(amtp)) {
3093 for (i = 1; i < NofAMmeth; i++) {
3094 CV * const cv = amtp->table[i];
3096 SvREFCNT_dec_NN(MUTABLE_SV(cv));
3097 amtp->table[i] = NULL;
3105 =for apidoc Gv_AMupdate
3107 Recalculates overload magic in the package given by C<stash>.
3113 =item 1 on success and there is some overload
3115 =item 0 if there is no overload
3117 =item -1 if some error occurred and it couldn't croak (because C<destructing>
3126 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
3128 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
3130 const struct mro_meta* stash_meta = HvMROMETA(stash);
3133 PERL_ARGS_ASSERT_GV_AMUPDATE;
3135 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
3137 const AMT * const amtp = (AMT*)mg->mg_ptr;
3138 if (amtp->was_ok_sub == newgen) {
3139 return AMT_AMAGIC(amtp) ? 1 : 0;
3141 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
3144 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
3147 amt.was_ok_sub = newgen;
3148 amt.fallback = AMGfallNO;
3154 bool deref_seen = 0;
3157 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
3159 /* Try to find via inheritance. */
3160 GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
3161 SV * const sv = gv ? GvSV(gv) : NULL;
3166 if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
3169 #ifdef PERL_DONT_CREATE_GVSV
3171 NOOP; /* Equivalent to !SvTRUE and !SvOK */
3174 else if (SvTRUE(sv))
3175 /* don't need to set overloading here because fallback => 1
3176 * is the default setting for classes without overloading */
3177 amt.fallback=AMGfallYES;
3178 else if (SvOK(sv)) {
3179 amt.fallback=AMGfallNEVER;
3186 assert(HvHasAUX(stash));
3187 /* initially assume the worst */
3188 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
3190 for (i = 1; i < NofAMmeth; i++) {
3191 const char * const cooky = PL_AMG_names[i];
3192 /* Human-readable form, for debugging: */
3193 const char * const cp = AMG_id2name(i);
3194 const STRLEN l = PL_AMG_namelens[i];
3196 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
3197 cp, HvNAME_get(stash)) );
3198 /* don't fill the cache while looking up!
3199 Creation of inheritance stubs in intermediate packages may
3200 conflict with the logic of runtime method substitution.
3201 Indeed, for inheritance A -> B -> C, if C overloads "+0",
3202 then we could have created stubs for "(+0" in A and C too.
3203 But if B overloads "bool", we may want to use it for
3204 numifying instead of C's "+0". */
3205 gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
3207 if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) {
3208 const HEK * const gvhek = CvGvNAME_HEK(cv);
3209 const HEK * const stashek =
3210 HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)));
3211 if (memEQs(HEK_KEY(gvhek), HEK_LEN(gvhek), "nil")
3213 && memEQs(HEK_KEY(stashek), HEK_LEN(stashek), "overload")) {
3214 /* This is a hack to support autoloading..., while
3215 knowing *which* methods were declared as overloaded. */
3216 /* GvSV contains the name of the method. */
3218 SV *gvsv = GvSV(gv);
3220 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%" SVf256\
3221 "\" for overloaded \"%s\" in package \"%.256s\"\n",
3222 (void*)GvSV(gv), cp, HvNAME(stash)) );
3223 if (!gvsv || !SvPOK(gvsv)
3224 || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
3226 /* Can be an import stub (created by "can"). */
3231 const SV * const name = (gvsv && SvPOK(gvsv))
3233 : newSVpvs_flags("???", SVs_TEMP);
3234 /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
3235 Perl_croak(aTHX_ "%s method \"%" SVf256
3236 "\" overloading \"%s\" "\
3237 "in package \"%" HEKf256 "\"",
3238 (GvCVGEN(gv) ? "Stub found while resolving"
3246 cv = GvCV(gv = ngv);
3248 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
3249 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
3250 GvNAME(CvGV(cv))) );
3252 } else if (gv) { /* Autoloaded... */
3253 cv = MUTABLE_CV(gv);
3256 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
3272 /* none of @{} etc overloaded; we can do $obj->[N] quicker.
3273 * NB - aux var invalid here, HvARRAY() could have been
3274 * reallocated since it was assigned to */
3275 HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF;
3278 AMT_AMAGIC_on(&amt);
3279 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
3280 (char*)&amt, sizeof(AMT));
3284 /* Here we have no table: */
3286 AMT_AMAGIC_off(&amt);
3287 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
3288 (char*)&amt, sizeof(AMTS));
3293 =for apidoc gv_handler
3295 Implements C<StashHANDLER>, which you should use instead
3301 Perl_gv_handler(pTHX_ HV *stash, I32 id)
3306 struct mro_meta* stash_meta;
3308 if (!stash || !HvNAME_get(stash))
3311 stash_meta = HvMROMETA(stash);
3312 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
3314 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
3317 if (Gv_AMupdate(stash, 0) == -1)
3319 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
3322 amtp = (AMT*)mg->mg_ptr;
3323 if ( amtp->was_ok_sub != newgen )
3325 if (AMT_AMAGIC(amtp)) {
3326 CV * const ret = amtp->table[id];
3327 if (ret && isGV(ret)) { /* Autoloading stab */
3328 /* Passing it through may have resulted in a warning
3329 "Inherited AUTOLOAD for a non-method deprecated", since
3330 our caller is going through a function call, not a method call.
3331 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
3332 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
3344 /* Implement tryAMAGICun_MG macro.
3345 Do get magic, then see if the stack arg is overloaded and if so call it.
3347 AMGf_numeric apply sv_2num to the stack arg.
3351 Perl_try_amagic_un(pTHX_ int method, int flags) {
3354 SV* const arg = TOPs;
3358 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
3359 AMGf_noright | AMGf_unary
3360 | (flags & AMGf_numarg))))
3362 /* where the op is of the form:
3363 * $lex = $x op $y (where the assign is optimised away)
3364 * then assign the returned value to targ and return that;
3365 * otherwise return the value directly
3367 if ( (PL_opargs[PL_op->op_type] & OA_TARGLEX)
3368 && (PL_op->op_private & OPpTARGET_MY))
3371 sv_setsv(TARG, tmpsv);
3381 if ((flags & AMGf_numeric) && SvROK(arg))
3387 /* Implement tryAMAGICbin_MG macro.
3388 Do get magic, then see if the two stack args are overloaded and if so
3391 AMGf_assign op may be called as mutator (eg +=)
3392 AMGf_numeric apply sv_2num to the stack arg.
3396 Perl_try_amagic_bin(pTHX_ int method, int flags) {
3398 SV* const left = TOPm1s;
3399 SV* const right = TOPs;
3405 if (SvAMAGIC(left) || SvAMAGIC(right)) {
3407 /* STACKED implies mutator variant, e.g. $x += 1 */
3408 bool mutator = (flags & AMGf_assign) && (PL_op->op_flags & OPf_STACKED);
3410 tmpsv = amagic_call(left, right, method,
3411 (mutator ? AMGf_assign: 0)
3412 | (flags & AMGf_numarg));
3415 /* where the op is one of the two forms:
3417 * $lex = $x op $y (where the assign is optimised away)
3418 * then assign the returned value to targ and return that;
3419 * otherwise return the value directly
3422 || ( (PL_opargs[PL_op->op_type] & OA_TARGLEX)
3423 && (PL_op->op_private & OPpTARGET_MY)))
3426 TARG = mutator ? *SP : PAD_SV(PL_op->op_targ);
3427 sv_setsv(TARG, tmpsv);
3438 if(left==right && SvGMAGICAL(left)) {
3439 SV * const left = sv_newmortal();
3441 /* Print the uninitialized warning now, so it includes the vari-
3444 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
3445 sv_setbool(left, FALSE);
3447 else sv_setsv_flags(left, right, 0);
3450 if (flags & AMGf_numeric) {
3452 *(sp-1) = sv_2num(TOPm1s);
3454 *sp = sv_2num(right);
3460 =for apidoc amagic_deref_call
3462 Perform C<method> overloading dereferencing on C<ref>, returning the
3463 dereferenced result. C<method> must be one of the dereference operations given
3466 If overloading is inactive on C<ref>, returns C<ref> itself.
3472 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
3476 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
3480 /* return quickly if none of the deref ops are overloaded */
3481 stash = SvSTASH(SvRV(ref));
3482 assert(HvHasAUX(stash));
3483 if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF)
3486 while ((tmpsv = amagic_call(ref, &PL_sv_undef, method,
3487 AMGf_noright | AMGf_unary))) {
3489 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
3490 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
3491 /* Bail out if it returns us the same reference. */
3498 return tmpsv ? tmpsv : ref;
3502 Perl_amagic_is_enabled(pTHX_ int method)
3504 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
3506 assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
3508 if ( !lex_mask || !SvOK(lex_mask) )
3509 /* overloading lexically disabled */
3511 else if ( lex_mask && SvPOK(lex_mask) ) {
3512 /* we have an entry in the hints hash, check if method has been
3513 * masked by overloading.pm */
3515 const int offset = method / 8;
3516 const int bit = method % 8;
3517 char *pv = SvPV(lex_mask, len);
3519 /* Bit set, so this overloading operator is disabled */
3520 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
3527 =for apidoc amagic_call
3529 Perform the overloaded (active magic) operation given by C<method>.
3530 C<method> is one of the values found in F<overload.h>.
3532 C<flags> affects how the operation is performed, as follows:
3536 =item C<AMGf_noleft>
3538 C<left> is not to be used in this operation.
3540 =item C<AMGf_noright>
3542 C<right> is not to be used in this operation.
3546 The operation is done only on just one operand.
3548 =item C<AMGf_assign>
3550 The operation changes one of the operands, e.g., $x += 1
3558 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
3562 CV **cvp=NULL, **ocvp=NULL;
3563 AMT *amtp=NULL, *oamtp=NULL;
3564 int off = 0, off1, lr = 0, notfound = 0;
3565 int postpr = 0, force_cpy = 0;
3566 int assign = AMGf_assign & flags;
3567 const int assignshift = assign ? 1 : 0;
3568 int use_default_op = 0;
3569 int force_scalar = 0;
3575 PERL_ARGS_ASSERT_AMAGIC_CALL;
3577 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
3578 if (!amagic_is_enabled(method)) return NULL;
3581 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
3582 && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
3583 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3584 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3585 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
3587 && ((cv = cvp[off=method+assignshift])
3588 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
3594 cv = cvp[off=method]))))
3596 lr = -1; /* Call method for left argument */
3598 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
3601 /* look for substituted methods */
3602 /* In all the covered cases we should be called with assign==0. */
3606 if ((cv = cvp[off=add_ass_amg])
3607 || ((cv = cvp[off = add_amg])
3608 && (force_cpy = 0, (postpr = 1)))) {
3609 right = &PL_sv_yes; lr = -1; assign = 1;
3614 if ((cv = cvp[off = subtr_ass_amg])
3615 || ((cv = cvp[off = subtr_amg])
3616 && (force_cpy = 0, (postpr=1)))) {
3617 right = &PL_sv_yes; lr = -1; assign = 1;
3621 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
3624 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
3627 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
3630 (void)((cv = cvp[off=bool__amg])
3631 || (cv = cvp[off=numer_amg])
3632 || (cv = cvp[off=string_amg]));
3639 * SV* ref causes confusion with the interpreter variable of
3642 SV* const tmpRef=SvRV(left);
3643 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
3645 * Just to be extra cautious. Maybe in some
3646 * additional cases sv_setsv is safe, too.
3648 SV* const newref = newSVsv(tmpRef);
3649 SvOBJECT_on(newref);
3650 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
3651 delegate to the stash. */
3652 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
3658 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
3659 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
3660 SV* const nullsv=&PL_sv_zero;
3662 SV* const lessp = amagic_call(left,nullsv,
3663 lt_amg,AMGf_noright);
3664 logic = SvTRUE_NN(lessp);
3666 SV* const lessp = amagic_call(left,nullsv,
3667 ncmp_amg,AMGf_noright);
3668 logic = (SvNV(lessp) < 0);
3671 if (off==subtr_amg) {
3682 if ((cv = cvp[off=subtr_amg])) {
3689 case iter_amg: /* XXXX Eventually should do to_gv. */
3690 case ftest_amg: /* XXXX Eventually should do to_gv. */
3693 return NULL; /* Delegate operation to standard mechanisms. */
3701 return left; /* Delegate operation to standard mechanisms. */
3706 if (!cv) goto not_found;
3707 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
3708 && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
3709 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3710 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3711 ? (amtp = (AMT*)mg->mg_ptr)->table
3713 && (cv = cvp[off=method])) { /* Method for right
3716 } else if (((cvp && amtp->fallback > AMGfallNEVER)
3717 || (ocvp && oamtp->fallback > AMGfallNEVER))
3718 && !(flags & AMGf_unary)) {
3719 /* We look for substitution for
3720 * comparison operations and
3722 if (method==concat_amg || method==concat_ass_amg
3723 || method==repeat_amg || method==repeat_ass_amg) {
3724 return NULL; /* Delegate operation to string conversion */
3746 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
3750 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
3760 not_found: /* No method found, either report or croak */
3768 return left; /* Delegate operation to standard mechanisms. */
3770 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
3771 notfound = 1; lr = -1;
3772 } else if (cvp && (cv=cvp[nomethod_amg])) {
3773 notfound = 1; lr = 1;
3774 } else if ((use_default_op =
3775 (!ocvp || oamtp->fallback >= AMGfallYES)
3776 && (!cvp || amtp->fallback >= AMGfallYES))
3778 /* Skip generating the "no method found" message. */
3782 if (off==-1) off=method;
3783 msg = sv_2mortal(Perl_newSVpvf(aTHX_
3784 "Operation \"%s\": no method found,%sargument %s%" SVf "%s%" SVf,
3785 AMG_id2name(method + assignshift),
3786 (flags & AMGf_unary ? " " : "\n\tleft "),
3788 "in overloaded package ":
3789 "has no overloaded magic",
3791 SVfARG(newSVhek_mortal(HvNAME_HEK(SvSTASH(SvRV(left))))):
3794 ",\n\tright argument in overloaded package ":
3797 : ",\n\tright argument has no overloaded magic"),
3799 SVfARG(newSVhek_mortal(HvNAME_HEK(SvSTASH(SvRV(right))))):
3800 SVfARG(&PL_sv_no)));
3801 if (use_default_op) {
3802 DEBUG_o( Perl_deb(aTHX_ "%" SVf, SVfARG(msg)) );
3804 Perl_croak(aTHX_ "%" SVf, SVfARG(msg));
3808 force_cpy = force_cpy || assign;
3813 /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
3814 * operation. we need this to return a value, so that it can be assigned
3815 * later on, in the postpr block (case inc_amg/dec_amg), even if the
3816 * increment or decrement was itself called in void context */
3822 if (off == subtr_amg)
3825 /* in these cases, we're calling an assignment variant of an operator
3826 * (+= rather than +, for instance). regardless of whether it's a
3827 * fallback or not, it always has to return a value, which will be
3828 * assigned to the proper variable later */
3848 /* the copy constructor always needs to return a value */
3852 /* because of the way these are implemented (they don't perform the
3853 * dereferencing themselves, they return a reference that perl then
3854 * dereferences later), they always have to be in scalar context */
3862 /* these don't have an op of their own; they're triggered by their parent
3863 * op, so the context there isn't meaningful ('$a and foo()' in void
3864 * context still needs to pass scalar context on to $a's bool overload) */
3874 DEBUG_o(Perl_deb(aTHX_
3875 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %" SVf "%s\n",
3877 method+assignshift==off? "" :
3879 method+assignshift==off? "" :
3880 AMG_id2name(method+assignshift),
3881 method+assignshift==off? "" : "\")",
3882 flags & AMGf_unary? "" :
3883 lr==1 ? " for right argument": " for left argument",
3884 flags & AMGf_unary? " for argument" : "",
3885 stash ? SVfARG(newSVhek_mortal(HvNAME_HEK(stash))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
3886 fl? ",\n\tassignment variant used": "") );
3889 /* Since we use shallow copy during assignment, we need
3890 * to dublicate the contents, probably calling user-supplied
3891 * version of copy operator
3893 /* We need to copy in following cases:
3894 * a) Assignment form was called.
3895 * assignshift==1, assign==T, method + 1 == off
3896 * b) Increment or decrement, called directly.
3897 * assignshift==0, assign==0, method + 0 == off
3898 * c) Increment or decrement, translated to assignment add/subtr.
3899 * assignshift==0, assign==T,
3901 * d) Increment or decrement, translated to nomethod.
3902 * assignshift==0, assign==0,
3904 * e) Assignment form translated to nomethod.
3905 * assignshift==1, assign==T, method + 1 != off
3908 /* off is method, method+assignshift, or a result of opcode substitution.
3909 * In the latter case assignshift==0, so only notfound case is important.
3911 if ( (lr == -1) && ( ( (method + assignshift == off)
3912 && (assign || (method == inc_amg) || (method == dec_amg)))
3915 /* newSVsv does not behave as advertised, so we copy missing
3916 * information by hand */
3917 SV *tmpRef = SvRV(left);
3919 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
3920 SvRV_set(left, rv_copy);
3922 SvREFCNT_dec_NN(tmpRef);
3930 const bool oldcatch = CATCH_GET;
3932 /* for multiconcat, we may call overload several times,
3933 * with the context of individual concats being scalar,
3934 * regardless of the overall context of the multiconcat op
3936 U8 gimme = (force_scalar || PL_op->op_type == OP_MULTICONCAT)
3937 ? G_SCALAR : GIMME_V;
3940 Zero(&myop, 1, BINOP);
3941 myop.op_last = (OP *) &myop;
3942 myop.op_next = NULL;
3943 myop.op_flags = OPf_STACKED;
3947 myop.op_flags |= OPf_WANT_VOID;
3950 if (flags & AMGf_want_list) {
3951 myop.op_flags |= OPf_WANT_LIST;
3956 myop.op_flags |= OPf_WANT_SCALAR;
3960 PUSHSTACKi(PERLSI_OVERLOAD);
3963 PL_op = (OP *) &myop;
3964 if (PERLDB_SUB && PL_curstash != PL_debstash)
3965 PL_op->op_private |= OPpENTERSUB_DB;
3966 Perl_pp_pushmark(aTHX);
3968 EXTEND(SP, notfound + 5);
3969 PUSHs(lr>0? right: left);
3970 PUSHs(lr>0? left: right);
3971 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3973 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3974 AMG_id2namelen(method + assignshift), SVs_TEMP));
3976 else if (flags & AMGf_numarg)
3977 PUSHs(&PL_sv_undef);
3978 if (flags & AMGf_numarg)
3980 PUSHs(MUTABLE_SV(cv));
3984 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3988 nret = SP - (PL_stack_base + oldmark);
3992 /* returning NULL has another meaning, and we check the context
3993 * at the call site too, so this can be differentiated from the
3996 SP = PL_stack_base + oldmark;
3999 if (flags & AMGf_want_list) {
4000 res = newSV_type_mortal(SVt_PVAV);
4001 av_extend((AV *)res, nret);
4003 av_store((AV *)res, nret, POPs);
4014 CATCH_SET(oldcatch);
4021 ans=SvIV(res)<=0; break;
4024 ans=SvIV(res)<0; break;
4027 ans=SvIV(res)>=0; break;
4030 ans=SvIV(res)>0; break;
4033 ans=SvIV(res)==0; break;
4036 ans=SvIV(res)!=0; break;
4039 SvSetSV(left,res); return left;
4041 ans=!SvTRUE_NN(res); break;
4046 } else if (method==copy_amg) {
4048 Perl_croak(aTHX_ "Copy method did not return a reference");
4050 return SvREFCNT_inc(SvRV(res));
4058 =for apidoc gv_name_set
4060 Set the name for GV C<gv> to C<name> which is C<len> bytes long. Thus it may
4061 contain embedded NUL characters.
4063 If C<flags> contains C<SVf_UTF8>, the name is treated as being encoded in
4064 UTF-8; otherwise not.
4070 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
4074 PERL_ARGS_ASSERT_GV_NAME_SET;
4077 Perl_croak(aTHX_ "panic: gv name too long (%" UVuf ")", (UV) len);
4079 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
4080 unshare_hek(GvNAME_HEK(gv));
4083 PERL_HASH(hash, name, len);
4084 GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
4088 =for apidoc gv_try_downgrade
4090 If the typeglob C<gv> can be expressed more succinctly, by having
4091 something other than a real GV in its place in the stash, replace it
4092 with the optimised form. Basic requirements for this are that C<gv>
4093 is a real typeglob, is sufficiently ordinary, and is only referenced
4094 from its package. This function is meant to be used when a GV has been
4095 looked up in part to see what was there, causing upgrading, but based
4096 on what was found it turns out that the real GV isn't required after all.
4098 If C<gv> is a completely empty typeglob, it is deleted from the stash.
4100 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
4101 sub, the typeglob is replaced with a scalar-reference placeholder that
4102 more compactly represents the same thing.
4108 Perl_gv_try_downgrade(pTHX_ GV *gv)
4114 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
4116 /* XXX Why and where does this leave dangling pointers during global
4118 if (PL_phase == PERL_PHASE_DESTRUCT) return;
4120 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
4121 !SvOBJECT(gv) && !SvREADONLY(gv) &&
4122 isGV_with_GP(gv) && GvGP(gv) &&
4123 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
4124 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
4125 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
4127 if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv)
4129 if (SvMAGICAL(gv)) {
4131 /* only backref magic is allowed */
4132 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
4134 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
4135 if (mg->mg_type != PERL_MAGIC_backref)
4141 HEK *gvnhek = GvNAME_HEK(gv);
4142 (void)hv_deletehek(stash, gvnhek, G_DISCARD);
4143 } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
4144 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
4145 CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv &&
4146 CvCONST(cv) && !CvNOWARN_AMBIGUOUS(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
4147 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
4148 (namehek = GvNAME_HEK(gv)) &&
4149 (gvp = hv_fetchhek(stash, namehek, 0)) &&
4151 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
4152 const bool imported = cBOOL(GvIMPORTED_CV(gv));
4156 SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
4158 /* See also: 'SET_SVANY_FOR_BODYLESS_IV' in sv.c */
4159 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
4160 STRUCT_OFFSET(XPVIV, xiv_iv));
4161 SvRV_set(gv, value);
4166 Perl_gv_override(pTHX_ const char * const name, const STRLEN len)
4168 GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV);
4170 PERL_ARGS_ASSERT_GV_OVERRIDE;
4171 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv;
4172 gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE);
4173 gv = gvp ? *gvp : NULL;
4174 if (gv && !isGV(gv)) {
4175 if (!SvPCS_IMPORTED(gv)) return NULL;
4176 gv_init(gv, PL_globalstash, name, len, 0);
4179 return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL;
4185 core_xsub(pTHX_ CV* cv)
4188 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
4193 * ex: set ts=8 sts=4 sw=4 et: