This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
gv.c: Added gv_init_(sv|pv|pvn), renamed gv_init_sv as gv_init_svtype.
[perl5.git] / gv.c
CommitLineData
a0d0e21e 1/* gv.c
79072805 2 *
1129b882 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
67fbe0e1 4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others
79072805
LW
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
a0d0e21e
LW
9 */
10
11/*
12 * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure
4ac71550 13 * of your inquisitiveness, I shall spend all the rest of my days in answering
a0d0e21e
LW
14 * you. What more do you want to know?'
15 * 'The names of all the stars, and of all living things, and the whole
16 * history of Middle-earth and Over-heaven and of the Sundering Seas,'
17 * laughed Pippin.
4ac71550 18 *
cdad3b53 19 * [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"]
79072805
LW
20 */
21
ccfc67b7
JH
22/*
23=head1 GV Functions
166f8a29
DM
24
25A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
26It is a structure that holds a pointer to a scalar, an array, a hash etc,
27corresponding to $foo, @foo, %foo.
28
29GVs are usually found as values in stashes (symbol table hashes) where
30Perl stores its global variables.
31
32=cut
ccfc67b7
JH
33*/
34
79072805 35#include "EXTERN.h"
864dbfa3 36#define PERL_IN_GV_C
79072805 37#include "perl.h"
8261f8eb 38#include "overload.c"
4aaa4757 39#include "keywords.h"
79072805 40
f54cb97a
AL
41static const char S_autoload[] = "AUTOLOAD";
42static const STRLEN S_autolen = sizeof(S_autoload)-1;
5c7983e5 43
c69033f2 44GV *
d5713896 45Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
c69033f2 46{
d5713896 47 SV **where;
7918f24d 48
13be902c
FC
49 if (
50 !gv
51 || (
52 SvTYPE((const SV *)gv) != SVt_PVGV
53 && SvTYPE((const SV *)gv) != SVt_PVLV
54 )
55 ) {
bb85b28a
NC
56 const char *what;
57 if (type == SVt_PVIO) {
58 /*
59 * if it walks like a dirhandle, then let's assume that
60 * this is a dirhandle.
61 */
332c2eac 62 what = OP_IS_DIRHOP(PL_op->op_type) ?
bb85b28a
NC
63 "dirhandle" : "filehandle";
64 /* diag_listed_as: Bad symbol for filehandle */
65 } else if (type == SVt_PVHV) {
66 what = "hash";
67 } else {
68 what = type == SVt_PVAV ? "array" : "scalar";
69 }
70 Perl_croak(aTHX_ "Bad symbol for %s", what);
71 }
d5713896
NC
72
73 if (type == SVt_PVHV) {
74 where = (SV **)&GvHV(gv);
75 } else if (type == SVt_PVAV) {
76 where = (SV **)&GvAV(gv);
bb85b28a
NC
77 } else if (type == SVt_PVIO) {
78 where = (SV **)&GvIOp(gv);
d5713896
NC
79 } else {
80 where = &GvSV(gv);
81 }
7918f24d 82
d5713896
NC
83 if (!*where)
84 *where = newSV_type(type);
79072805
LW
85 return gv;
86}
87
88GV *
864dbfa3 89Perl_gv_fetchfile(pTHX_ const char *name)
79072805 90{
7918f24d 91 PERL_ARGS_ASSERT_GV_FETCHFILE;
d9095cec
NC
92 return gv_fetchfile_flags(name, strlen(name), 0);
93}
94
95GV *
96Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
97 const U32 flags)
98{
97aff369 99 dVAR;
4116122e 100 char smallbuf[128];
53d95988 101 char *tmpbuf;
d9095cec 102 const STRLEN tmplen = namelen + 2;
79072805
LW
103 GV *gv;
104
7918f24d 105 PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
d9095cec
NC
106 PERL_UNUSED_ARG(flags);
107
1d7c1841 108 if (!PL_defstash)
a0714e2c 109 return NULL;
1d7c1841 110
d9095cec 111 if (tmplen <= sizeof smallbuf)
53d95988
CS
112 tmpbuf = smallbuf;
113 else
798b63bc 114 Newx(tmpbuf, tmplen, char);
0ac0412a 115 /* This is where the debugger's %{"::_<$filename"} hash is created */
53d95988
CS
116 tmpbuf[0] = '_';
117 tmpbuf[1] = '<';
d9095cec
NC
118 memcpy(tmpbuf + 2, name, namelen);
119 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
1d7c1841 120 if (!isGV(gv)) {
d9095cec 121 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
c69033f2 122#ifdef PERL_DONT_CREATE_GVSV
d9095cec 123 GvSV(gv) = newSVpvn(name, namelen);
c69033f2 124#else
d9095cec 125 sv_setpvn(GvSV(gv), name, namelen);
c69033f2 126#endif
1d7c1841 127 }
5a9a79a4
FC
128 if ((PERLDB_LINE || PERLDB_SAVESRC) && !GvAV(gv))
129 hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
53d95988
CS
130 if (tmpbuf != smallbuf)
131 Safefree(tmpbuf);
79072805
LW
132 return gv;
133}
134
62d55b22
NC
135/*
136=for apidoc gv_const_sv
137
138If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
139inlining, or C<gv> is a placeholder reference that would be promoted to such
140a typeglob, then returns the value returned by the sub. Otherwise, returns
141NULL.
142
143=cut
144*/
145
146SV *
147Perl_gv_const_sv(pTHX_ GV *gv)
148{
7918f24d
NC
149 PERL_ARGS_ASSERT_GV_CONST_SV;
150
62d55b22
NC
151 if (SvTYPE(gv) == SVt_PVGV)
152 return cv_const_sv(GvCVu(gv));
153 return SvROK(gv) ? SvRV(gv) : NULL;
154}
155
12816592
NC
156GP *
157Perl_newGP(pTHX_ GV *const gv)
158{
159 GP *gp;
19bad673
NC
160 U32 hash;
161#ifdef USE_ITHREADS
1df5f7c1
NC
162 const char *const file
163 = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : "";
19bad673
NC
164 const STRLEN len = strlen(file);
165#else
166 SV *const temp_sv = CopFILESV(PL_curcop);
167 const char *file;
168 STRLEN len;
169
7918f24d
NC
170 PERL_ARGS_ASSERT_NEWGP;
171
19bad673
NC
172 if (temp_sv) {
173 file = SvPVX(temp_sv);
174 len = SvCUR(temp_sv);
175 } else {
176 file = "";
177 len = 0;
178 }
179#endif
f4890806
NC
180
181 PERL_HASH(hash, file, len);
182
12816592
NC
183 Newxz(gp, 1, GP);
184
185#ifndef PERL_DONT_CREATE_GVSV
b5c2dcb8 186 gp->gp_sv = newSV(0);
12816592
NC
187#endif
188
1df5f7c1 189 gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0;
12816592
NC
190 /* XXX Ideally this cast would be replaced with a change to const char*
191 in the struct. */
f4890806 192 gp->gp_file_hek = share_hek(file, len, hash);
12816592
NC
193 gp->gp_egv = gv;
194 gp->gp_refcnt = 1;
195
196 return gp;
197}
198
803f2748
DM
199/* Assign CvGV(cv) = gv, handling weak references.
200 * See also S_anonymise_cv_maybe */
201
202void
203Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
204{
205 GV * const oldgv = CvGV(cv);
206 PERL_ARGS_ASSERT_CVGV_SET;
207
208 if (oldgv == gv)
209 return;
210
211 if (oldgv) {
cfc1e951 212 if (CvCVGV_RC(cv)) {
803f2748 213 SvREFCNT_dec(oldgv);
cfc1e951
DM
214 CvCVGV_RC_off(cv);
215 }
803f2748 216 else {
803f2748
DM
217 sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
218 }
219 }
220
b3f91e91 221 SvANY(cv)->xcv_gv = gv;
c794ca97 222 assert(!CvCVGV_RC(cv));
803f2748
DM
223
224 if (!gv)
225 return;
226
c794ca97
DM
227 if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
228 Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
229 else {
cfc1e951 230 CvCVGV_RC_on(cv);
803f2748
DM
231 SvREFCNT_inc_simple_void_NN(gv);
232 }
803f2748
DM
233}
234
c68d9564
Z
235/* Assign CvSTASH(cv) = st, handling weak references. */
236
237void
238Perl_cvstash_set(pTHX_ CV *cv, HV *st)
239{
240 HV *oldst = CvSTASH(cv);
241 PERL_ARGS_ASSERT_CVSTASH_SET;
242 if (oldst == st)
243 return;
244 if (oldst)
245 sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
246 SvANY(cv)->xcv_stash = st;
247 if (st)
248 Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
249}
803f2748 250
463ee0b2 251void
e6066781
BF
252Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, int multi, U32 flags)
253{
254 char *namepv;
255 STRLEN namelen;
256 PERL_ARGS_ASSERT_GV_INIT_SV;
257 namepv = SvPV(namesv, namelen);
258 if (SvUTF8(namesv))
259 flags |= SVf_UTF8;
260 gv_init_pvn(gv, stash, namepv, namelen, multi, flags);
261}
262
263void
264Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, int multi, U32 flags)
265{
266 PERL_ARGS_ASSERT_GV_INIT_PV;
267 gv_init_pvn(gv, stash, name, strlen(name), multi, flags);
268}
269
270void
271Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi, U32 flags)
463ee0b2 272{
27da23d5 273 dVAR;
3b6733bf
NC
274 const U32 old_type = SvTYPE(gv);
275 const bool doproto = old_type > SVt_NULL;
024963f8 276 char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
49a54bbe 277 const STRLEN protolen = proto ? SvCUR(gv) : 0;
756cb477 278 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
1ccdb730 279 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
756cb477 280
e6066781 281 PERL_ARGS_ASSERT_GV_INIT_PVN;
756cb477
NC
282 assert (!(proto && has_constant));
283
284 if (has_constant) {
5c1f4d79
NC
285 /* The constant has to be a simple scalar type. */
286 switch (SvTYPE(has_constant)) {
287 case SVt_PVAV:
288 case SVt_PVHV:
289 case SVt_PVCV:
290 case SVt_PVFM:
291 case SVt_PVIO:
292 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
293 sv_reftype(has_constant, 0));
42d0e0b7 294 default: NOOP;
5c1f4d79 295 }
756cb477
NC
296 SvRV_set(gv, NULL);
297 SvROK_off(gv);
298 }
463ee0b2 299
3b6733bf
NC
300
301 if (old_type < SVt_PVGV) {
302 if (old_type >= SVt_PV)
303 SvCUR_set(gv, 0);
ad64d0ec 304 sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
3b6733bf 305 }
55d729e4
GS
306 if (SvLEN(gv)) {
307 if (proto) {
f880fe2f 308 SvPV_set(gv, NULL);
b162af07 309 SvLEN_set(gv, 0);
55d729e4
GS
310 SvPOK_off(gv);
311 } else
94010e71 312 Safefree(SvPVX_mutable(gv));
55d729e4 313 }
2e5b91de
NC
314 SvIOK_off(gv);
315 isGV_with_GP_on(gv);
12816592 316
c43ae56f 317 GvGP_set(gv, Perl_newGP(aTHX_ gv));
e15faf7d
NC
318 GvSTASH(gv) = stash;
319 if (stash)
ad64d0ec 320 Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
ae8cc45f 321 gv_name_set(gv, name, len, GV_ADD);
23ad5bf5 322 if (multi || doproto) /* doproto means it _was_ mentioned */
a5f75d66 323 GvMULTI_on(gv);
55d729e4 324 if (doproto) { /* Replicate part of newSUB here. */
e3d2b9e7 325 CV *cv;
55d729e4 326 ENTER;
756cb477 327 if (has_constant) {
e5c69c9b
DM
328 char *name0 = NULL;
329 if (name[len])
330 /* newCONSTSUB doesn't take a len arg, so make sure we
331 * give it a \0-terminated string */
332 name0 = savepvn(name,len);
333
756cb477 334 /* newCONSTSUB takes ownership of the reference from us. */
e5c69c9b 335 cv = newCONSTSUB(stash, (name0 ? name0 : name), has_constant);
75bd28cf
FC
336 /* In case op.c:S_process_special_blocks stole it: */
337 if (!GvCV(gv))
c43ae56f 338 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
439cdf38 339 assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
e5c69c9b
DM
340 if (name0)
341 Safefree(name0);
1ccdb730
NC
342 /* If this reference was a copy of another, then the subroutine
343 must have been "imported", by a Perl space assignment to a GV
344 from a reference to CV. */
345 if (exported_constant)
346 GvIMPORTED_CV_on(gv);
756cb477 347 } else {
756cb477 348 (void) start_subparse(0,0); /* Create empty CV in compcv. */
e3d2b9e7 349 cv = PL_compcv;
c43ae56f 350 GvCV_set(gv,cv);
756cb477 351 }
55d729e4
GS
352 LEAVE;
353
e1a479c5 354 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
b3f91e91 355 CvGV_set(cv, gv);
e3d2b9e7 356 CvFILE_set_from_cop(cv, PL_curcop);
c68d9564 357 CvSTASH_set(cv, PL_curstash);
55d729e4 358 if (proto) {
e3d2b9e7 359 sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
49a54bbe 360 SV_HAS_TRAILING_NUL);
55d729e4
GS
361 }
362 }
463ee0b2
LW
363}
364
76e3520e 365STATIC void
e6066781 366S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
a0d0e21e 367{
e6066781 368 PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
7918f24d 369
a0d0e21e
LW
370 switch (sv_type) {
371 case SVt_PVIO:
372 (void)GvIOn(gv);
373 break;
374 case SVt_PVAV:
375 (void)GvAVn(gv);
376 break;
377 case SVt_PVHV:
378 (void)GvHVn(gv);
379 break;
c69033f2
NC
380#ifdef PERL_DONT_CREATE_GVSV
381 case SVt_NULL:
382 case SVt_PVCV:
383 case SVt_PVFM:
e654831b 384 case SVt_PVGV:
c69033f2
NC
385 break;
386 default:
dbdce04c
NC
387 if(GvSVn(gv)) {
388 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
389 If we just cast GvSVn(gv) to void, it ignores evaluating it for
390 its side effect */
391 }
c69033f2 392#endif
a0d0e21e
LW
393 }
394}
395
0f8d4b5e
FC
396static void core_xsub(pTHX_ CV* cv);
397
398static GV *
399S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
400 const char * const name, const STRLEN len,
401 const char * const fullname, STRLEN const fullen)
402{
403 const int code = keyword(name, len, 1);
404 static const char file[] = __FILE__;
405 CV *cv, *oldcompcv;
406 int opnum = 0;
407 SV *opnumsv;
408 bool ampable = TRUE; /* &{}-able */
409 COP *oldcurcop;
410 yy_parser *oldparser;
411 I32 oldsavestack_ix;
412
413 assert(gv || stash);
414 assert(name);
415 assert(stash || fullname);
416
417 if (!fullname && !HvENAME(stash)) return NULL; /* pathological case
418 that would require
419 inlining newATTRSUB */
420 if (code >= 0) return NULL; /* not overridable */
421 switch (-code) {
422 /* no support for \&CORE::infix;
423 no support for funcs that take labels, as their parsing is
424 weird */
425 case KEY_and: case KEY_cmp: case KEY_CORE: case KEY_dump:
426 case KEY_eq: case KEY_ge:
427 case KEY_gt: case KEY_le: case KEY_lt: case KEY_ne:
428 case KEY_or: case KEY_x: case KEY_xor:
429 return NULL;
430 case KEY_chdir:
431 case KEY_chomp: case KEY_chop:
432 case KEY_each: case KEY_eof: case KEY_exec:
433 case KEY_keys:
434 case KEY_lstat:
435 case KEY_pop:
436 case KEY_push:
437 case KEY_shift:
438 case KEY_splice:
439 case KEY_stat:
440 case KEY_system:
441 case KEY_truncate: case KEY_unlink:
442 case KEY_unshift:
443 case KEY_values:
444 ampable = FALSE;
445 }
446 if (!gv) {
447 gv = (GV *)newSV(0);
448 gv_init(gv, stash, name, len, TRUE);
449 }
450 if (ampable) {
451 ENTER;
452 oldcurcop = PL_curcop;
453 oldparser = PL_parser;
454 lex_start(NULL, NULL, 0);
455 oldcompcv = PL_compcv;
456 PL_compcv = NULL; /* Prevent start_subparse from setting
457 CvOUTSIDE. */
458 oldsavestack_ix = start_subparse(FALSE,0);
459 cv = PL_compcv;
460 }
461 else {
462 /* Avoid calling newXS, as it calls us, and things start to
463 get hairy. */
464 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
465 GvCV_set(gv,cv);
466 GvCVGEN(gv) = 0;
467 mro_method_changed_in(GvSTASH(gv));
468 CvISXSUB_on(cv);
469 CvXSUB(cv) = core_xsub;
470 }
471 CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
472 from PL_curcop. */
473 (void)gv_fetchfile(file);
474 CvFILE(cv) = (char *)file;
475 /* XXX This is inefficient, as doing things this order causes
476 a prototype check in newATTRSUB. But we have to do
477 it this order as we need an op number before calling
478 new ATTRSUB. */
479 (void)core_prototype((SV *)cv, name, code, &opnum);
73c02f15
FC
480 if (stash && (fullname || !fullen))
481 (void)hv_store(stash,name,len,(SV *)gv,0);
0f8d4b5e
FC
482 if (ampable) {
483 SV *tmpstr;
484 CvLVALUE_on(cv);
485 if (!fullname) {
486 tmpstr = newSVhek(HvENAME_HEK(stash));
487 sv_catpvs(tmpstr, "::");
488 sv_catpvn(tmpstr,name,len);
489 }
490 else tmpstr = newSVpvn_share(fullname,fullen,0);
491 newATTRSUB(oldsavestack_ix,
492 newSVOP(OP_CONST, 0, tmpstr),
493 NULL,NULL,
494 coresub_op(
495 opnum
496 ? newSVuv((UV)opnum)
497 : newSVpvn(name,len),
498 code, opnum
499 )
500 );
501 assert(GvCV(gv) == cv);
502 if (opnum != OP_VEC && opnum != OP_SUBSTR)
503 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
504 LEAVE;
505 PL_parser = oldparser;
506 PL_curcop = oldcurcop;
507 PL_compcv = oldcompcv;
508 }
509 opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
510 cv_set_call_checker(
511 cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
512 );
513 SvREFCNT_dec(opnumsv);
514 return gv;
515}
516
954c1994
GS
517/*
518=for apidoc gv_fetchmeth
519
520Returns the glob with the given C<name> and a defined subroutine or
521C<NULL>. The glob lives in the given C<stash>, or in the stashes
07766739 522accessible via @ISA and UNIVERSAL::.
954c1994
GS
523
524The argument C<level> should be either 0 or -1. If C<level==0>, as a
525side-effect creates a glob with the given C<name> in the given C<stash>
526which in the case of success contains an alias for the subroutine, and sets
e1a479c5 527up caching info for this glob.
954c1994
GS
528
529This function grants C<"SUPER"> token as a postfix of the stash name. The
530GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
4929bf7b 531visible to Perl code. So when calling C<call_sv>, you should not use
954c1994 532the GV directly; instead, you should use the method's CV, which can be
b267980d 533obtained from the GV with the C<GvCV> macro.
954c1994
GS
534
535=cut
536*/
537
e1a479c5
BB
538/* NOTE: No support for tied ISA */
539
79072805 540GV *
864dbfa3 541Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
79072805 542{
97aff369 543 dVAR;
463ee0b2 544 GV** gvp;
e1a479c5
BB
545 AV* linear_av;
546 SV** linear_svp;
547 SV* linear_sv;
548 HV* cstash;
549 GV* candidate = NULL;
550 CV* cand_cv = NULL;
e1a479c5 551 GV* topgv = NULL;
bfcb3514 552 const char *hvname;
e1a479c5
BB
553 I32 create = (level >= 0) ? 1 : 0;
554 I32 items;
555 STRLEN packlen;
556 U32 topgen_cmp;
a0d0e21e 557
7918f24d
NC
558 PERL_ARGS_ASSERT_GV_FETCHMETH;
559
af09ea45
IK
560 /* UNIVERSAL methods should be callable without a stash */
561 if (!stash) {
e1a479c5 562 create = 0; /* probably appropriate */
da51bb9b 563 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
af09ea45
IK
564 return 0;
565 }
566
e1a479c5
BB
567 assert(stash);
568
bfcb3514
NC
569 hvname = HvNAME_get(stash);
570 if (!hvname)
e1a479c5 571 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
e27ad1f2 572
e1a479c5
BB
573 assert(hvname);
574 assert(name);
463ee0b2 575
bfcb3514 576 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
44a8e56a 577
dd69841b 578 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
e1a479c5
BB
579
580 /* check locally for a real method or a cache entry */
581 gvp = (GV**)hv_fetch(stash, name, len, create);
582 if(gvp) {
583 topgv = *gvp;
0f8d4b5e 584 have_gv:
e1a479c5
BB
585 assert(topgv);
586 if (SvTYPE(topgv) != SVt_PVGV)
587 gv_init(topgv, stash, name, len, TRUE);
588 if ((cand_cv = GvCV(topgv))) {
589 /* If genuine method or valid cache entry, use it */
590 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
591 return topgv;
592 }
593 else {
594 /* stale cache entry, junk it and move on */
595 SvREFCNT_dec(cand_cv);
c43ae56f
DM
596 GvCV_set(topgv, NULL);
597 cand_cv = NULL;
e1a479c5
BB
598 GvCVGEN(topgv) = 0;
599 }
600 }
601 else if (GvCVGEN(topgv) == topgen_cmp) {
602 /* cache indicates no such method definitively */
603 return 0;
604 }
0f8d4b5e
FC
605 else if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
606 && strnEQ(hvname, "CORE", 4)
73c02f15 607 && S_maybe_add_coresub(aTHX_ stash,topgv,name,len,0,1))
0f8d4b5e 608 goto have_gv;
463ee0b2 609 }
79072805 610
e1a479c5
BB
611 packlen = HvNAMELEN_get(stash);
612 if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
613 HV* basestash;
614 packlen -= 7;
615 basestash = gv_stashpvn(hvname, packlen, GV_ADD);
616 linear_av = mro_get_linear_isa(basestash);
9607fc9c 617 }
e1a479c5
BB
618 else {
619 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
79072805 620 }
a0d0e21e 621
e1a479c5
BB
622 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
623 items = AvFILLp(linear_av); /* no +1, to skip over self */
624 while (items--) {
625 linear_sv = *linear_svp++;
626 assert(linear_sv);
627 cstash = gv_stashsv(linear_sv, 0);
628
dd69841b 629 if (!cstash) {
a2a5de95
NC
630 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
631 SVfARG(linear_sv), hvname);
e1a479c5
BB
632 continue;
633 }
9607fc9c 634
e1a479c5
BB
635 assert(cstash);
636
637 gvp = (GV**)hv_fetch(cstash, name, len, 0);
0f8d4b5e
FC
638 if (!gvp) {
639 if (len > 1 && HvNAMELEN_get(cstash) == 4) {
640 const char *hvname = HvNAME(cstash); assert(hvname);
641 if (strnEQ(hvname, "CORE", 4)
642 && (candidate =
643 S_maybe_add_coresub(aTHX_ cstash,NULL,name,len,0,0)
644 ))
645 goto have_candidate;
646 }
647 continue;
648 }
649 else candidate = *gvp;
650 have_candidate:
e1a479c5
BB
651 assert(candidate);
652 if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE);
653 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
654 /*
655 * Found real method, cache method in topgv if:
656 * 1. topgv has no synonyms (else inheritance crosses wires)
657 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
658 */
659 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
9bfbb681
VP
660 CV *old_cv = GvCV(topgv);
661 SvREFCNT_dec(old_cv);
e1a479c5 662 SvREFCNT_inc_simple_void_NN(cand_cv);
c43ae56f 663 GvCV_set(topgv, cand_cv);
e1a479c5
BB
664 GvCVGEN(topgv) = topgen_cmp;
665 }
666 return candidate;
667 }
668 }
9607fc9c 669
e1a479c5
BB
670 /* Check UNIVERSAL without caching */
671 if(level == 0 || level == -1) {
672 candidate = gv_fetchmeth(NULL, name, len, 1);
673 if(candidate) {
674 cand_cv = GvCV(candidate);
675 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
9bfbb681
VP
676 CV *old_cv = GvCV(topgv);
677 SvREFCNT_dec(old_cv);
e1a479c5 678 SvREFCNT_inc_simple_void_NN(cand_cv);
c43ae56f 679 GvCV_set(topgv, cand_cv);
e1a479c5
BB
680 GvCVGEN(topgv) = topgen_cmp;
681 }
682 return candidate;
683 }
684 }
685
686 if (topgv && GvREFCNT(topgv) == 1) {
687 /* cache the fact that the method is not defined */
688 GvCVGEN(topgv) = topgen_cmp;
a0d0e21e
LW
689 }
690
79072805
LW
691 return 0;
692}
693
954c1994 694/*
611c1e95
IZ
695=for apidoc gv_fetchmeth_autoload
696
697Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
698Returns a glob for the subroutine.
699
700For an autoloaded subroutine without a GV, will create a GV even
701if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
702of the result may be zero.
703
704=cut
705*/
706
707GV *
708Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
709{
710 GV *gv = gv_fetchmeth(stash, name, len, level);
711
7918f24d
NC
712 PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD;
713
611c1e95 714 if (!gv) {
611c1e95
IZ
715 CV *cv;
716 GV **gvp;
717
718 if (!stash)
6136c704 719 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
7edbdc6b 720 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
6136c704 721 return NULL;
5c7983e5 722 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
6136c704 723 return NULL;
611c1e95
IZ
724 cv = GvCV(gv);
725 if (!(CvROOT(cv) || CvXSUB(cv)))
6136c704 726 return NULL;
611c1e95
IZ
727 /* Have an autoload */
728 if (level < 0) /* Cannot do without a stub */
729 gv_fetchmeth(stash, name, len, 0);
730 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
731 if (!gvp)
6136c704 732 return NULL;
611c1e95
IZ
733 return *gvp;
734 }
735 return gv;
736}
737
738/*
954c1994
GS
739=for apidoc gv_fetchmethod_autoload
740
741Returns the glob which contains the subroutine to call to invoke the method
742on the C<stash>. In fact in the presence of autoloading this may be the
743glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
b267980d 744already setup.
954c1994
GS
745
746The third parameter of C<gv_fetchmethod_autoload> determines whether
747AUTOLOAD lookup is performed if the given method is not present: non-zero
b267980d 748means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
954c1994 749Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
b267980d 750with a non-zero C<autoload> parameter.
954c1994
GS
751
752These functions grant C<"SUPER"> token as a prefix of the method name. Note
753that if you want to keep the returned glob for a long time, you need to
754check for it being "AUTOLOAD", since at the later time the call may load a
755different subroutine due to $AUTOLOAD changing its value. Use the glob
b267980d 756created via a side effect to do this.
954c1994
GS
757
758These functions have the same side-effects and as C<gv_fetchmeth> with
759C<level==0>. C<name> should be writable if contains C<':'> or C<'
760''>. The warning against passing the GV returned by C<gv_fetchmeth> to
b267980d 761C<call_sv> apply equally to these functions.
954c1994
GS
762
763=cut
764*/
765
7d3b1f61
BB
766STATIC HV*
767S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen)
768{
769 AV* superisa;
770 GV** gvp;
771 GV* gv;
772 HV* stash;
773
7918f24d
NC
774 PERL_ARGS_ASSERT_GV_GET_SUPER_PKG;
775
7d3b1f61
BB
776 stash = gv_stashpvn(name, namelen, 0);
777 if(stash) return stash;
778
779 /* If we must create it, give it an @ISA array containing
780 the real package this SUPER is for, so that it's tied
781 into the cache invalidation code correctly */
782 stash = gv_stashpvn(name, namelen, GV_ADD);
783 gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
784 gv = *gvp;
785 gv_init(gv, stash, "ISA", 3, TRUE);
786 superisa = GvAVn(gv);
787 GvMULTI_on(gv);
ad64d0ec 788 sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0);
8e3a4a30 789#ifdef USE_ITHREADS
7d3b1f61 790 av_push(superisa, newSVpv(CopSTASHPV(PL_curcop), 0));
8e3a4a30
NC
791#else
792 av_push(superisa, newSVhek(CopSTASH(PL_curcop)
793 ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
794#endif
7d3b1f61
BB
795
796 return stash;
797}
798
dc848c6f 799GV *
864dbfa3 800Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
dc848c6f 801{
547bb267
NC
802 PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
803
256d1bb2
NC
804 return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
805}
806
807/* Don't merge this yet, as it's likely to get a len parameter, and possibly
808 even a U32 hash */
809GV *
810Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags)
811{
97aff369 812 dVAR;
08105a92 813 register const char *nend;
c445ea15 814 const char *nsplit = NULL;
a0d0e21e 815 GV* gv;
0dae17bd 816 HV* ostash = stash;
c94593d0 817 const char * const origname = name;
ad64d0ec 818 SV *const error_report = MUTABLE_SV(stash);
256d1bb2
NC
819 const U32 autoload = flags & GV_AUTOLOAD;
820 const U32 do_croak = flags & GV_CROAK;
0dae17bd 821
547bb267 822 PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS;
7918f24d 823
eff494dd 824 if (SvTYPE(stash) < SVt_PVHV)
5c284bb0 825 stash = NULL;
c9bf4021
NC
826 else {
827 /* The only way stash can become NULL later on is if nsplit is set,
828 which in turn means that there is no need for a SVt_PVHV case
829 the error reporting code. */
830 }
b267980d 831
463ee0b2 832 for (nend = name; *nend; nend++) {
c94593d0 833 if (*nend == '\'') {
a0d0e21e 834 nsplit = nend;
c94593d0
NC
835 name = nend + 1;
836 }
837 else if (*nend == ':' && *(nend + 1) == ':') {
838 nsplit = nend++;
839 name = nend + 1;
840 }
a0d0e21e
LW
841 }
842 if (nsplit) {
7edbdc6b 843 if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
9607fc9c 844 /* ->SUPER::method should really be looked up in original stash */
b37c2d43 845 SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
1d7c1841 846 CopSTASHPV(PL_curcop)));
af09ea45 847 /* __PACKAGE__::SUPER stash should be autovivified */
7d3b1f61 848 stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr));
cea2e8a9 849 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
bfcb3514 850 origname, HvNAME_get(stash), name) );
4633a7c4 851 }
e189a56d 852 else {
af09ea45 853 /* don't autovifify if ->NoSuchStash::method */
da51bb9b 854 stash = gv_stashpvn(origname, nsplit - origname, 0);
e189a56d
IK
855
856 /* however, explicit calls to Pkg::SUPER::method may
857 happen, and may require autovivification to work */
858 if (!stash && (nsplit - origname) >= 7 &&
859 strnEQ(nsplit - 7, "::SUPER", 7) &&
da51bb9b 860 gv_stashpvn(origname, nsplit - origname - 7, 0))
7d3b1f61 861 stash = gv_get_super_pkg(origname, nsplit - origname);
e189a56d 862 }
0dae17bd 863 ostash = stash;
4633a7c4
LW
864 }
865
9607fc9c 866 gv = gv_fetchmeth(stash, name, nend - name, 0);
a0d0e21e 867 if (!gv) {
2f6e0fe7 868 if (strEQ(name,"import") || strEQ(name,"unimport"))
159b6efe 869 gv = MUTABLE_GV(&PL_sv_yes);
dc848c6f 870 else if (autoload)
0dae17bd 871 gv = gv_autoload4(ostash, name, nend - name, TRUE);
256d1bb2
NC
872 if (!gv && do_croak) {
873 /* Right now this is exclusively for the benefit of S_method_common
874 in pp_hot.c */
875 if (stash) {
15e6cdd9
DG
876 /* If we can't find an IO::File method, it might be a call on
877 * a filehandle. If IO:File has not been loaded, try to
878 * require it first instead of croaking */
879 const char *stash_name = HvNAME_get(stash);
31b05a0f
FR
880 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
881 && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
882 STR_WITH_LEN("IO/File.pm"), 0,
883 HV_FETCH_ISEXISTS, NULL, 0)
15e6cdd9 884 ) {
31b05a0f 885 require_pv("IO/File.pm");
15e6cdd9
DG
886 gv = gv_fetchmeth(stash, name, nend - name, 0);
887 if (gv)
888 return gv;
889 }
256d1bb2
NC
890 Perl_croak(aTHX_
891 "Can't locate object method \"%s\" via package \"%.*s\"",
c49b597d 892 name, (int)HvNAMELEN_get(stash), HvNAME_get(stash));
256d1bb2
NC
893 }
894 else {
895 STRLEN packlen;
896 const char *packname;
897
256d1bb2
NC
898 if (nsplit) {
899 packlen = nsplit - origname;
900 packname = origname;
256d1bb2
NC
901 } else {
902 packname = SvPV_const(error_report, packlen);
903 }
904
905 Perl_croak(aTHX_
906 "Can't locate object method \"%s\" via package \"%.*s\""
907 " (perhaps you forgot to load \"%.*s\"?)",
908 name, (int)packlen, packname, (int)packlen, packname);
909 }
910 }
463ee0b2 911 }
dc848c6f 912 else if (autoload) {
9d4ba2ae 913 CV* const cv = GvCV(gv);
09280a33
CS
914 if (!CvROOT(cv) && !CvXSUB(cv)) {
915 GV* stubgv;
916 GV* autogv;
917
918 if (CvANON(cv))
919 stubgv = gv;
920 else {
921 stubgv = CvGV(cv);
922 if (GvCV(stubgv) != cv) /* orphaned import */
923 stubgv = gv;
924 }
925 autogv = gv_autoload4(GvSTASH(stubgv),
926 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
dc848c6f
PP
927 if (autogv)
928 gv = autogv;
929 }
930 }
44a8e56a
PP
931
932 return gv;
933}
934
935GV*
864dbfa3 936Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
44a8e56a 937{
27da23d5 938 dVAR;
44a8e56a
PP
939 GV* gv;
940 CV* cv;
941 HV* varstash;
942 GV* vargv;
943 SV* varsv;
e1ec3a88 944 const char *packname = "";
eae70eaa 945 STRLEN packname_len = 0;
44a8e56a 946
7918f24d
NC
947 PERL_ARGS_ASSERT_GV_AUTOLOAD4;
948
7edbdc6b 949 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
a0714e2c 950 return NULL;
0dae17bd
GS
951 if (stash) {
952 if (SvTYPE(stash) < SVt_PVHV) {
ad64d0ec 953 packname = SvPV_const(MUTABLE_SV(stash), packname_len);
5c284bb0 954 stash = NULL;
0dae17bd
GS
955 }
956 else {
bfcb3514 957 packname = HvNAME_get(stash);
7423f6db 958 packname_len = HvNAMELEN_get(stash);
0dae17bd
GS
959 }
960 }
5c7983e5 961 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
a0714e2c 962 return NULL;
dc848c6f
PP
963 cv = GvCV(gv);
964
adb5a9ae 965 if (!(CvROOT(cv) || CvXSUB(cv)))
a0714e2c 966 return NULL;
ed850460 967
dc848c6f
PP
968 /*
969 * Inheriting AUTOLOAD for non-methods works ... for now.
970 */
041457d9 971 if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
041457d9 972 )
d1d15184
NC
973 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
974 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
975 packname, (int)len, name);
44a8e56a 976
aed2304a 977 if (CvISXSUB(cv)) {
adb5a9ae
DM
978 /* rather than lookup/init $AUTOLOAD here
979 * only to have the XSUB do another lookup for $AUTOLOAD
980 * and split that value on the last '::',
981 * pass along the same data via some unused fields in the CV
982 */
c68d9564 983 CvSTASH_set(cv, stash);
f880fe2f 984 SvPV_set(cv, (char *)name); /* cast to lose constness warning */
b162af07 985 SvCUR_set(cv, len);
adb5a9ae
DM
986 return gv;
987 }
adb5a9ae 988
44a8e56a
PP
989 /*
990 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
991 * The subroutine's original name may not be "AUTOLOAD", so we don't
992 * use that, but for lack of anything better we will use the sub's
993 * original package to look up $AUTOLOAD.
994 */
995 varstash = GvSTASH(CvGV(cv));
5c7983e5 996 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
3d35f11b
GS
997 ENTER;
998
c69033f2 999 if (!isGV(vargv)) {
5c7983e5 1000 gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
c69033f2 1001#ifdef PERL_DONT_CREATE_GVSV
561b68a9 1002 GvSV(vargv) = newSV(0);
c69033f2
NC
1003#endif
1004 }
3d35f11b 1005 LEAVE;
e203899d 1006 varsv = GvSVn(vargv);
7423f6db 1007 sv_setpvn(varsv, packname, packname_len);
396482e1 1008 sv_catpvs(varsv, "::");
d40bf27b
NC
1009 /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1010 tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
1011 sv_catpvn_mg(varsv, name, len);
a0d0e21e
LW
1012 return gv;
1013}
1014
44a2ac75
YO
1015
1016/* require_tie_mod() internal routine for requiring a module
486ec47a 1017 * that implements the logic of automatic ties like %! and %-
44a2ac75
YO
1018 *
1019 * The "gv" parameter should be the glob.
45cbc99a
RGS
1020 * "varpv" holds the name of the var, used for error messages.
1021 * "namesv" holds the module name. Its refcount will be decremented.
44a2ac75 1022 * "methpv" holds the method name to test for to check that things
45cbc99a
RGS
1023 * are working reasonably close to as expected.
1024 * "flags": if flag & 1 then save the scalar before loading.
44a2ac75
YO
1025 * For the protection of $! to work (it is set by this routine)
1026 * the sv slot must already be magicalized.
d2c93421 1027 */
44a2ac75
YO
1028STATIC HV*
1029S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
d2c93421 1030{
27da23d5 1031 dVAR;
da51bb9b 1032 HV* stash = gv_stashsv(namesv, 0);
45cbc99a 1033
7918f24d
NC
1034 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1035
44a2ac75 1036 if (!stash || !(gv_fetchmethod(stash, methpv))) {
45cbc99a
RGS
1037 SV *module = newSVsv(namesv);
1038 char varname = *varpv; /* varpv might be clobbered by load_module,
1039 so save it. For the moment it's always
1040 a single char. */
d2c93421 1041 dSP;
d2c93421 1042 ENTER;
44a2ac75 1043 if ( flags & 1 )
45cbc99a 1044 save_scalar(gv);
cac54379 1045 PUSHSTACKi(PERLSI_MAGIC);
45cbc99a 1046 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
cac54379 1047 POPSTACK;
d2c93421
RH
1048 LEAVE;
1049 SPAGAIN;
da51bb9b 1050 stash = gv_stashsv(namesv, 0);
44a2ac75 1051 if (!stash)
45cbc99a
RGS
1052 Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available",
1053 varname, SVfARG(namesv));
1054 else if (!gv_fetchmethod(stash, methpv))
1055 Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s",
1056 varname, SVfARG(namesv), methpv);
d2c93421 1057 }
45cbc99a 1058 SvREFCNT_dec(namesv);
44a2ac75 1059 return stash;
d2c93421
RH
1060}
1061
954c1994
GS
1062/*
1063=for apidoc gv_stashpv
1064
da51bb9b 1065Returns a pointer to the stash for a specified package. Uses C<strlen> to
75c442e4 1066determine the length of C<name>, then calls C<gv_stashpvn()>.
954c1994
GS
1067
1068=cut
1069*/
1070
a0d0e21e 1071HV*
864dbfa3 1072Perl_gv_stashpv(pTHX_ const char *name, I32 create)
a0d0e21e 1073{
7918f24d 1074 PERL_ARGS_ASSERT_GV_STASHPV;
dc437b57
PP
1075 return gv_stashpvn(name, strlen(name), create);
1076}
1077
bc96cb06
SH
1078/*
1079=for apidoc gv_stashpvn
1080
da51bb9b
NC
1081Returns a pointer to the stash for a specified package. The C<namelen>
1082parameter indicates the length of the C<name>, in bytes. C<flags> is passed
1083to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1084created if it does not already exist. If the package does not exist and
1085C<flags> is 0 (or any other setting that does not create packages) then NULL
1086is returned.
1087
bc96cb06
SH
1088
1089=cut
1090*/
1091
dc437b57 1092HV*
da51bb9b 1093Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
dc437b57 1094{
0cea0058 1095 char smallbuf[128];
46fc3d4c 1096 char *tmpbuf;
a0d0e21e
LW
1097 HV *stash;
1098 GV *tmpgv;
add0ecde 1099 U32 tmplen = namelen + 2;
dc437b57 1100
7918f24d
NC
1101 PERL_ARGS_ASSERT_GV_STASHPVN;
1102
add0ecde 1103 if (tmplen <= sizeof smallbuf)
46fc3d4c
PP
1104 tmpbuf = smallbuf;
1105 else
add0ecde
VP
1106 Newx(tmpbuf, tmplen, char);
1107 Copy(name, tmpbuf, namelen, char);
1108 tmpbuf[namelen] = ':';
1109 tmpbuf[namelen+1] = ':';
1110 tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
46fc3d4c
PP
1111 if (tmpbuf != smallbuf)
1112 Safefree(tmpbuf);
a0d0e21e 1113 if (!tmpgv)
da51bb9b 1114 return NULL;
a0d0e21e 1115 stash = GvHV(tmpgv);
1f656fcf 1116 if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
9efb5c72 1117 assert(stash);
1f656fcf 1118 if (!HvNAME_get(stash)) {
1a063a89 1119 hv_name_set(stash, name, namelen, 0);
1f656fcf
FC
1120
1121 /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1122 /* If the containing stash has multiple effective
1123 names, see that this one gets them, too. */
1124 if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1125 mro_package_moved(stash, NULL, tmpgv, 1);
1126 }
a0d0e21e 1127 return stash;
463ee0b2
LW
1128}
1129
954c1994
GS
1130/*
1131=for apidoc gv_stashsv
1132
da51bb9b 1133Returns a pointer to the stash for a specified package. See C<gv_stashpvn>.
954c1994
GS
1134
1135=cut
1136*/
1137
a0d0e21e 1138HV*
da51bb9b 1139Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
a0d0e21e 1140{
dc437b57 1141 STRLEN len;
9d4ba2ae 1142 const char * const ptr = SvPV_const(sv,len);
7918f24d
NC
1143
1144 PERL_ARGS_ASSERT_GV_STASHSV;
1145
da51bb9b 1146 return gv_stashpvn(ptr, len, flags);
a0d0e21e
LW
1147}
1148
1149
463ee0b2 1150GV *
fe9845cc 1151Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
7918f24d 1152 PERL_ARGS_ASSERT_GV_FETCHPV;
b7787f18 1153 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
7a5fd60d
NC
1154}
1155
1156GV *
fe9845cc 1157Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
7a5fd60d 1158 STRLEN len;
77cb3b01
FC
1159 const char * const nambeg =
1160 SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
7918f24d 1161 PERL_ARGS_ASSERT_GV_FETCHSV;
7a5fd60d
NC
1162 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1163}
1164
ad7cce9f 1165STATIC void
290a1700 1166S_gv_magicalize_isa(pTHX_ GV *gv)
ad7cce9f
FR
1167{
1168 AV* av;
1169
1170 PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1171
1172 av = GvAVn(gv);
1173 GvMULTI_on(gv);
1174 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1175 NULL, 0);
ad7cce9f
FR
1176}
1177
1178STATIC void
26469672 1179S_gv_magicalize_overload(pTHX_ GV *gv)
ad7cce9f
FR
1180{
1181 HV* hv;
1182
1183 PERL_ARGS_ASSERT_GV_MAGICALIZE_OVERLOAD;
1184
1185 hv = GvHVn(gv);
1186 GvMULTI_on(gv);
1187 hv_magic(hv, NULL, PERL_MAGIC_overload);
1188}
1189
7a5fd60d
NC
1190GV *
1191Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
fe9845cc 1192 const svtype sv_type)
79072805 1193{
97aff369 1194 dVAR;
08105a92 1195 register const char *name = nambeg;
c445ea15 1196 register GV *gv = NULL;
79072805 1197 GV**gvp;
79072805 1198 I32 len;
b3d904f3 1199 register const char *name_cursor;
c445ea15 1200 HV *stash = NULL;
add2581e 1201 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
e26df76a 1202 const I32 no_expand = flags & GV_NOEXPAND;
780a5241 1203 const I32 add = flags & ~GV_NOADD_MASK;
9da346da 1204 bool addmg = !!(flags & GV_ADDMG);
b3d904f3
NC
1205 const char *const name_end = nambeg + full_len;
1206 const char *const name_em1 = name_end - 1;
5e0caaeb 1207 U32 faking_it;
79072805 1208
7918f24d
NC
1209 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
1210
fafc274c
NC
1211 if (flags & GV_NOTQUAL) {
1212 /* Caller promised that there is no stash, so we can skip the check. */
1213 len = full_len;
1214 goto no_stash;
1215 }
1216
b208e10c
NC
1217 if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
1218 /* accidental stringify on a GV? */
c07a80fd 1219 name++;
b208e10c 1220 }
c07a80fd 1221
b3d904f3 1222 for (name_cursor = name; name_cursor < name_end; name_cursor++) {
46c0ec20
FC
1223 if (name_cursor < name_em1 &&
1224 ((*name_cursor == ':'
b3d904f3 1225 && name_cursor[1] == ':')
46c0ec20 1226 || *name_cursor == '\''))
463ee0b2 1227 {
463ee0b2 1228 if (!stash)
3280af22 1229 stash = PL_defstash;
dc437b57 1230 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
a0714e2c 1231 return NULL;
463ee0b2 1232
b3d904f3 1233 len = name_cursor - name;
088225fd 1234 if (name_cursor > nambeg) { /* Skip for initial :: or ' */
3a5b580c
NC
1235 const char *key;
1236 if (*name_cursor == ':') {
1237 key = name;
e771aaa9
NC
1238 len += 2;
1239 } else {
3a5b580c 1240 char *tmpbuf;
2ae0db35 1241 Newx(tmpbuf, len+2, char);
e771aaa9
NC
1242 Copy(name, tmpbuf, len, char);
1243 tmpbuf[len++] = ':';
1244 tmpbuf[len++] = ':';
3a5b580c 1245 key = tmpbuf;
e771aaa9 1246 }
3a5b580c 1247 gvp = (GV**)hv_fetch(stash, key, len, add);
a0714e2c 1248 gv = gvp ? *gvp : NULL;
159b6efe 1249 if (gv && gv != (const GV *)&PL_sv_undef) {
6fa846a0 1250 if (SvTYPE(gv) != SVt_PVGV)
3a5b580c 1251 gv_init(gv, stash, key, len, (add & GV_ADDMULTI));
6fa846a0
GS
1252 else
1253 GvMULTI_on(gv);
1254 }
3a5b580c 1255 if (key != name)
b9d2ea5b 1256 Safefree(key);
159b6efe 1257 if (!gv || gv == (const GV *)&PL_sv_undef)
a0714e2c 1258 return NULL;
85e6fe83 1259
463ee0b2 1260 if (!(stash = GvHV(gv)))
298d6511 1261 {
99ee9762
FC
1262 stash = GvHV(gv) = newHV();
1263 if (!HvNAME_get(stash)) {
e058c50a
FC
1264 if (GvSTASH(gv) == PL_defstash && len == 6
1265 && strnEQ(name, "CORE", 4))
1266 hv_name_set(stash, "CORE", 4, 0);
1267 else
1268 hv_name_set(
1269 stash, nambeg, name_cursor-nambeg, 0
1270 );
99ee9762
FC
1271 /* If the containing stash has multiple effective
1272 names, see that this one gets them, too. */
1273 if (HvAUX(GvSTASH(gv))->xhv_name_count)
1274 mro_package_moved(stash, NULL, gv, 1);
1275 }
298d6511 1276 }
99ee9762
FC
1277 else if (!HvNAME_get(stash))
1278 hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
463ee0b2
LW
1279 }
1280
b3d904f3
NC
1281 if (*name_cursor == ':')
1282 name_cursor++;
088225fd 1283 name = name_cursor+1;
ad6bfa9d 1284 if (name == name_end)
159b6efe
NC
1285 return gv
1286 ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
79072805 1287 }
79072805 1288 }
b3d904f3 1289 len = name_cursor - name;
463ee0b2
LW
1290
1291 /* No stash in name, so see how we can default */
1292
1293 if (!stash) {
fafc274c 1294 no_stash:
8ccce9ae 1295 if (len && isIDFIRST_lazy(name)) {
9607fc9c
PP
1296 bool global = FALSE;
1297
8ccce9ae
NC
1298 switch (len) {
1299 case 1:
18ea00d7 1300 if (*name == '_')
9d116dd7 1301 global = TRUE;
18ea00d7 1302 break;
8ccce9ae
NC
1303 case 3:
1304 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1305 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1306 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
9d116dd7 1307 global = TRUE;
18ea00d7 1308 break;
8ccce9ae
NC
1309 case 4:
1310 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1311 && name[3] == 'V')
9d116dd7 1312 global = TRUE;
18ea00d7 1313 break;
8ccce9ae
NC
1314 case 5:
1315 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1316 && name[3] == 'I' && name[4] == 'N')
463ee0b2 1317 global = TRUE;
18ea00d7 1318 break;
8ccce9ae
NC
1319 case 6:
1320 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1321 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1322 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1323 global = TRUE;
1324 break;
1325 case 7:
1326 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1327 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1328 && name[6] == 'T')
18ea00d7
NC
1329 global = TRUE;
1330 break;
463ee0b2 1331 }
9607fc9c 1332
463ee0b2 1333 if (global)
3280af22 1334 stash = PL_defstash;
923e4eb5 1335 else if (IN_PERL_COMPILETIME) {
3280af22
NIS
1336 stash = PL_curstash;
1337 if (add && (PL_hints & HINT_STRICT_VARS) &&
748a9306
LW
1338 sv_type != SVt_PVCV &&
1339 sv_type != SVt_PVGV &&
4633a7c4 1340 sv_type != SVt_PVFM &&
c07a80fd 1341 sv_type != SVt_PVIO &&
70ec6265
NC
1342 !(len == 1 && sv_type == SVt_PV &&
1343 (*name == 'a' || *name == 'b')) )
748a9306 1344 {
4633a7c4
LW
1345 gvp = (GV**)hv_fetch(stash,name,len,0);
1346 if (!gvp ||
159b6efe 1347 *gvp == (const GV *)&PL_sv_undef ||
a5f75d66
AD
1348 SvTYPE(*gvp) != SVt_PVGV)
1349 {
d4c19fe8 1350 stash = NULL;
a5f75d66 1351 }
155aba94
GS
1352 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
1353 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1354 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
4633a7c4 1355 {
fe13d51d 1356 /* diag_listed_as: Variable "%s" is not imported%s */
413ff9f6
FC
1357 Perl_ck_warner_d(
1358 aTHX_ packWARN(WARN_MISC),
1359 "Variable \"%c%s\" is not imported",
4633a7c4
LW
1360 sv_type == SVt_PVAV ? '@' :
1361 sv_type == SVt_PVHV ? '%' : '$',
1362 name);
8ebc5c01 1363 if (GvCVu(*gvp))
413ff9f6
FC
1364 Perl_ck_warner_d(
1365 aTHX_ packWARN(WARN_MISC),
1366 "\t(Did you mean &%s instead?)\n", name
1367 );
d4c19fe8 1368 stash = NULL;
4633a7c4 1369 }
a0d0e21e 1370 }
85e6fe83 1371 }
463ee0b2 1372 else
1d7c1841 1373 stash = CopSTASH(PL_curcop);
463ee0b2
LW
1374 }
1375 else
3280af22 1376 stash = PL_defstash;
463ee0b2
LW
1377 }
1378
1379 /* By this point we should have a stash and a name */
1380
a0d0e21e 1381 if (!stash) {
5a844595 1382 if (add) {
9d4ba2ae 1383 SV * const err = Perl_mess(aTHX_
5a844595
GS
1384 "Global symbol \"%s%s\" requires explicit package name",
1385 (sv_type == SVt_PV ? "$"
1386 : sv_type == SVt_PVAV ? "@"
1387 : sv_type == SVt_PVHV ? "%"
608b3986 1388 : ""), name);
e7f343b6 1389 GV *gv;
608b3986
AE
1390 if (USE_UTF8_IN_NAMES)
1391 SvUTF8_on(err);
1392 qerror(err);
76f68e9b 1393 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
e7f343b6
NC
1394 if(!gv) {
1395 /* symbol table under destruction */
1396 return NULL;
1397 }
1398 stash = GvHV(gv);
a0d0e21e 1399 }
d7aacf4e 1400 else
a0714e2c 1401 return NULL;
a0d0e21e
LW
1402 }
1403
1404 if (!SvREFCNT(stash)) /* symbol table under destruction */
a0714e2c 1405 return NULL;
a0d0e21e 1406
79072805 1407 gvp = (GV**)hv_fetch(stash,name,len,add);
23496c6e
FC
1408 if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
1409 if (addmg) gv = (GV *)newSV(0);
1410 else return NULL;
1411 }
914ecc63
FC
1412 else gv = *gvp, addmg = 0;
1413 /* From this point on, addmg means gv has not been inserted in the
1414 symtab yet. */
1415
79072805 1416 if (SvTYPE(gv) == SVt_PVGV) {
a0d0e21e 1417 if (add) {
a5f75d66 1418 GvMULTI_on(gv);
e6066781 1419 gv_init_svtype(gv, sv_type);
ccdda9cb
NC
1420 if (len == 1 && stash == PL_defstash
1421 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
44a2ac75
YO
1422 if (*name == '!')
1423 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
45cbc99a 1424 else if (*name == '-' || *name == '+')
192b9cd1 1425 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
45cbc99a 1426 }
af16de9f
FC
1427 else if (len == 3 && sv_type == SVt_PVAV
1428 && strnEQ(name, "ISA", 3)
1429 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
1430 gv_magicalize_isa(gv);
a0d0e21e 1431 }
79072805 1432 return gv;
add2581e 1433 } else if (no_init) {
23496c6e 1434 assert(!addmg);
55d729e4 1435 return gv;
e26df76a 1436 } else if (no_expand && SvROK(gv)) {
23496c6e 1437 assert(!addmg);
e26df76a 1438 return gv;
79072805 1439 }
93a17b20 1440
5e0caaeb
NC
1441 /* Adding a new symbol.
1442 Unless of course there was already something non-GV here, in which case
1443 we want to behave as if there was always a GV here, containing some sort
1444 of subroutine.
1445 Otherwise we run the risk of creating things like GvIO, which can cause
1446 subtle bugs. eg the one that tripped up SQL::Translator */
1447
1448 faking_it = SvOK(gv);
93a17b20 1449
9b387841
NC
1450 if (add & GV_ADDWARN)
1451 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
55d729e4 1452 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
93a17b20 1453
a0288114 1454 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
7272584d 1455 : (PL_dowarn & G_WARN_ON ) ) )
0453d815
PM
1456 GvMULTI_on(gv) ;
1457
93a17b20 1458 /* set up magic where warranted */
44428a46
FC
1459 if (stash != PL_defstash) { /* not the main stash */
1460 /* We only have to check for four names here: EXPORT, ISA, OVERLOAD
4aaa4757
FC
1461 and VERSION. All the others apply only to the main stash or to
1462 CORE (which is checked right after this). */
f4e68e82 1463 if (len > 2) {
b464bac0 1464 const char * const name2 = name + 1;
cc4c2da6 1465 switch (*name) {
cc4c2da6
NC
1466 case 'E':
1467 if (strnEQ(name2, "XPORT", 5))
1468 GvMULTI_on(gv);
1469 break;
1470 case 'I':
44428a46 1471 if (strEQ(name2, "SA"))
290a1700 1472 gv_magicalize_isa(gv);
cc4c2da6
NC
1473 break;
1474 case 'O':
44428a46 1475 if (strEQ(name2, "VERLOAD"))
ad7cce9f 1476 gv_magicalize_overload(gv);
cc4c2da6 1477 break;
44428a46
FC
1478 case 'V':
1479 if (strEQ(name2, "ERSION"))
1480 GvMULTI_on(gv);
1481 break;
4aaa4757
FC
1482 default:
1483 goto try_core;
1484 }
23496c6e 1485 goto add_magical_gv;
4aaa4757
FC
1486 }
1487 try_core:
1488 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1489 /* Avoid null warning: */
1490 const char * const stashname = HvNAME(stash); assert(stashname);
0f8d4b5e
FC
1491 if (strnEQ(stashname, "CORE", 4)
1492 && S_maybe_add_coresub(aTHX_
1493 addmg ? stash : 0, gv, name, len, nambeg, full_len
1494 ))
1495 addmg = 0;
44428a46
FC
1496 }
1497 }
1498 else if (len > 1) {
1499#ifndef EBCDIC
1500 if (*name > 'V' ) {
1501 NOOP;
1502 /* Nothing else to do.
1503 The compiler will probably turn the switch statement into a
1504 branch table. Make sure we avoid even that small overhead for
1505 the common case of lower case variable names. */
1506 } else
1507#endif
1508 {
1509 const char * const name2 = name + 1;
1510 switch (*name) {
1511 case 'A':
1512 if (strEQ(name2, "RGV")) {
1513 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1514 }
1515 else if (strEQ(name2, "RGVOUT")) {
1516 GvMULTI_on(gv);
1517 }
1518 break;
1519 case 'E':
1520 if (strnEQ(name2, "XPORT", 5))
1521 GvMULTI_on(gv);
1522 break;
1523 case 'I':
1524 if (strEQ(name2, "SA")) {
290a1700 1525 gv_magicalize_isa(gv);
44428a46
FC
1526 }
1527 break;
1528 case 'O':
1529 if (strEQ(name2, "VERLOAD")) {
ad7cce9f 1530 gv_magicalize_overload(gv);
44428a46
FC
1531 }
1532 break;
cc4c2da6
NC
1533 case 'S':
1534 if (strEQ(name2, "IG")) {
1535 HV *hv;
1536 I32 i;
d525a7b2
NC
1537 if (!PL_psig_name) {
1538 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
a02a5408 1539 Newxz(PL_psig_pend, SIG_SIZE, int);
d525a7b2 1540 PL_psig_ptr = PL_psig_name + SIG_SIZE;
0bdedcb3
NC
1541 } else {
1542 /* I think that the only way to get here is to re-use an
1543 embedded perl interpreter, where the previous
1544 use didn't clean up fully because
1545 PL_perl_destruct_level was 0. I'm not sure that we
1546 "support" that, in that I suspect in that scenario
1547 there are sufficient other garbage values left in the
1548 interpreter structure that something else will crash
1549 before we get here. I suspect that this is one of
1550 those "doctor, it hurts when I do this" bugs. */
d525a7b2 1551 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
0bdedcb3 1552 Zero(PL_psig_pend, SIG_SIZE, int);
cc4c2da6
NC
1553 }
1554 GvMULTI_on(gv);
1555 hv = GvHVn(gv);
a0714e2c 1556 hv_magic(hv, NULL, PERL_MAGIC_sig);
cc4c2da6 1557 for (i = 1; i < SIG_SIZE; i++) {
551405c4 1558 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
cc4c2da6
NC
1559 if (init)
1560 sv_setsv(*init, &PL_sv_undef);
cc4c2da6
NC
1561 }
1562 }
1563 break;
1564 case 'V':
1565 if (strEQ(name2, "ERSION"))
1566 GvMULTI_on(gv);
1567 break;
e5218da5
GA
1568 case '\003': /* $^CHILD_ERROR_NATIVE */
1569 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1570 goto magicalize;
1571 break;
cc4c2da6
NC
1572 case '\005': /* $^ENCODING */
1573 if (strEQ(name2, "NCODING"))
1574 goto magicalize;
1575 break;
9ebf26ad
FR
1576 case '\007': /* $^GLOBAL_PHASE */
1577 if (strEQ(name2, "LOBAL_PHASE"))
1578 goto ro_magicalize;
1579 break;
cde0cee5
YO
1580 case '\015': /* $^MATCH */
1581 if (strEQ(name2, "ATCH"))
2fdbfb4d 1582 goto magicalize;
cc4c2da6
NC
1583 case '\017': /* $^OPEN */
1584 if (strEQ(name2, "PEN"))
1585 goto magicalize;
1586 break;
cde0cee5
YO
1587 case '\020': /* $^PREMATCH $^POSTMATCH */
1588 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
9ebf26ad
FR
1589 goto magicalize;
1590 break;
cc4c2da6
NC
1591 case '\024': /* ${^TAINT} */
1592 if (strEQ(name2, "AINT"))
1593 goto ro_magicalize;
1594 break;
7cebcbc0 1595 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
a0288114 1596 if (strEQ(name2, "NICODE"))
cc4c2da6 1597 goto ro_magicalize;
a0288114 1598 if (strEQ(name2, "TF8LOCALE"))
7cebcbc0 1599 goto ro_magicalize;
e07ea26a
NC
1600 if (strEQ(name2, "TF8CACHE"))
1601 goto magicalize;
cc4c2da6
NC
1602 break;
1603 case '\027': /* $^WARNING_BITS */
1604 if (strEQ(name2, "ARNING_BITS"))
1605 goto magicalize;
1606 break;
1607 case '1':
1608 case '2':
1609 case '3':
1610 case '4':
1611 case '5':
1612 case '6':
1613 case '7':
1614 case '8':
1615 case '9':
85e6fe83 1616 {
2fdbfb4d
AB
1617 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1618 this test */
1619 /* This snippet is taken from is_gv_magical */
cc4c2da6
NC
1620 const char *end = name + len;
1621 while (--end > name) {
23496c6e 1622 if (!isDIGIT(*end)) goto add_magical_gv;
cc4c2da6 1623 }
2fdbfb4d 1624 goto magicalize;
1d7c1841 1625 }
dc437b57 1626 }
93a17b20 1627 }
392db708
NC
1628 } else {
1629 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1630 be case '\0' in this switch statement (ie a default case) */
cc4c2da6 1631 switch (*name) {
6361f656
AB
1632 case '&': /* $& */
1633 case '`': /* $` */
1634 case '\'': /* $' */
cc4c2da6
NC
1635 if (
1636 sv_type == SVt_PVAV ||
1637 sv_type == SVt_PVHV ||
1638 sv_type == SVt_PVCV ||
1639 sv_type == SVt_PVFM ||
1640 sv_type == SVt_PVIO
1641 ) { break; }
1642 PL_sawampersand = TRUE;
2fdbfb4d 1643 goto magicalize;
cc4c2da6 1644
6361f656 1645 case ':': /* $: */
c69033f2 1646 sv_setpv(GvSVn(gv),PL_chopset);
cc4c2da6
NC
1647 goto magicalize;
1648
6361f656 1649 case '?': /* $? */
ff0cee69 1650#ifdef COMPLEX_STATUS
c69033f2 1651 SvUPGRADE(GvSVn(gv), SVt_PVLV);
ff0cee69 1652#endif
cc4c2da6 1653 goto magicalize;
ff0cee69 1654
6361f656 1655 case '!': /* $! */
67261566 1656 GvMULTI_on(gv);
44a2ac75 1657 /* If %! has been used, automatically load Errno.pm. */
d2c93421 1658
ad64d0ec 1659 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
d2c93421 1660
44a2ac75 1661 /* magicalization must be done before require_tie_mod is called */
67261566 1662 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
44a2ac75 1663 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
d2c93421 1664
6cef1e77 1665 break;
6361f656
AB
1666 case '-': /* $- */
1667 case '+': /* $+ */
44a2ac75
YO
1668 GvMULTI_on(gv); /* no used once warnings here */
1669 {
44a2ac75 1670 AV* const av = GvAVn(gv);
ad64d0ec 1671 SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
44a2ac75 1672
ad64d0ec
NC
1673 sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1674 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
67261566 1675 if (avc)
44a2ac75 1676 SvREADONLY_on(GvSVn(gv));
44a2ac75 1677 SvREADONLY_on(av);
67261566
YO
1678
1679 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
192b9cd1 1680 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
67261566 1681
80305961 1682 break;
cc4c2da6 1683 }
6361f656
AB
1684 case '*': /* $* */
1685 case '#': /* $# */
9b387841
NC
1686 if (sv_type == SVt_PV)
1687 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1688 "$%c is no longer supported", *name);
8ae1fe26 1689 break;
6361f656 1690 case '|': /* $| */
c69033f2 1691 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
cc4c2da6
NC
1692 goto magicalize;
1693
b3ca2e83
NC
1694 case '\010': /* $^H */
1695 {
1696 HV *const hv = GvHVn(gv);
1697 hv_magic(hv, NULL, PERL_MAGIC_hints);
1698 }
1699 goto magicalize;
cc4c2da6 1700 case '\023': /* $^S */
2fdbfb4d
AB
1701 ro_magicalize:
1702 SvREADONLY_on(GvSVn(gv));
1703 /* FALL THROUGH */
6361f656
AB
1704 case '0': /* $0 */
1705 case '1': /* $1 */
1706 case '2': /* $2 */
1707 case '3': /* $3 */
1708 case '4': /* $4 */
1709 case '5': /* $5 */
1710 case '6': /* $6 */
1711 case '7': /* $7 */
1712 case '8': /* $8 */
1713 case '9': /* $9 */
1714 case '[': /* $[ */
1715 case '^': /* $^ */
1716 case '~': /* $~ */
1717 case '=': /* $= */
1718 case '%': /* $% */
1719 case '.': /* $. */
1720 case '(': /* $( */
1721 case ')': /* $) */
1722 case '<': /* $< */
1723 case '>': /* $> */
1724 case '\\': /* $\ */
1725 case '/': /* $/ */
9cdac2a2 1726 case '$': /* $$ */
cc4c2da6
NC
1727 case '\001': /* $^A */
1728 case '\003': /* $^C */
1729 case '\004': /* $^D */
1730 case '\005': /* $^E */
1731 case '\006': /* $^F */
cc4c2da6
NC
1732 case '\011': /* $^I, NOT \t in EBCDIC */
1733 case '\016': /* $^N */
1734 case '\017': /* $^O */
1735 case '\020': /* $^P */
1736 case '\024': /* $^T */
1737 case '\027': /* $^W */
1738 magicalize:
ad64d0ec 1739 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
cc4c2da6 1740 break;
e521374c 1741
cc4c2da6 1742 case '\014': /* $^L */
76f68e9b 1743 sv_setpvs(GvSVn(gv),"\f");
c69033f2 1744 PL_formfeed = GvSVn(gv);
463ee0b2 1745 break;
6361f656 1746 case ';': /* $; */
76f68e9b 1747 sv_setpvs(GvSVn(gv),"\034");
463ee0b2 1748 break;
6361f656 1749 case ']': /* $] */
cc4c2da6 1750 {
3638bf15 1751 SV * const sv = GvSV(gv);
d7aa5382 1752 if (!sv_derived_from(PL_patchlevel, "version"))
ac0e6a2f 1753 upg_version(PL_patchlevel, TRUE);
7d54d38e
SH
1754 GvSV(gv) = vnumify(PL_patchlevel);
1755 SvREADONLY_on(GvSV(gv));
1756 SvREFCNT_dec(sv);
93a17b20
LW
1757 }
1758 break;
cc4c2da6
NC
1759 case '\026': /* $^V */
1760 {
3638bf15 1761 SV * const sv = GvSV(gv);
f9be5ac8
DM
1762 GvSV(gv) = new_version(PL_patchlevel);
1763 SvREADONLY_on(GvSV(gv));
1764 SvREFCNT_dec(sv);
16070b82
GS
1765 }
1766 break;
cc4c2da6 1767 }
79072805 1768 }
23496c6e
FC
1769 add_magical_gv:
1770 if (addmg) {
1771 if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
1772 GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
1773 ))
0f43181e 1774 (void)hv_store(stash,name,len,(SV *)gv,0);
23496c6e
FC
1775 else SvREFCNT_dec(gv), gv = NULL;
1776 }
e6066781 1777 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
93a17b20 1778 return gv;
79072805
LW
1779}
1780
1781void
35a4481c 1782Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
43693395 1783{
35a4481c 1784 const char *name;
7423f6db 1785 STRLEN namelen;
35a4481c 1786 const HV * const hv = GvSTASH(gv);
7918f24d
NC
1787
1788 PERL_ARGS_ASSERT_GV_FULLNAME4;
1789
43693395 1790 if (!hv) {
0c34ef67 1791 SvOK_off(sv);
43693395
GS
1792 return;
1793 }
666ea192 1794 sv_setpv(sv, prefix ? prefix : "");
a0288114 1795
bfcb3514 1796 name = HvNAME_get(hv);
7423f6db
NC
1797 if (name) {
1798 namelen = HvNAMELEN_get(hv);
1799 } else {
e27ad1f2 1800 name = "__ANON__";
7423f6db
NC
1801 namelen = 8;
1802 }
a0288114 1803
e27ad1f2 1804 if (keepmain || strNE(name, "main")) {
7423f6db 1805 sv_catpvn(sv,name,namelen);
396482e1 1806 sv_catpvs(sv,"::");
43693395 1807 }
257984c0 1808 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
43693395
GS
1809}
1810
1811void
35a4481c 1812Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
43693395 1813{
099be4f1 1814 const GV * const egv = GvEGVx(gv);
7918f24d
NC
1815
1816 PERL_ARGS_ASSERT_GV_EFULLNAME4;
1817
46c461b5 1818 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
43693395
GS
1819}
1820
79072805 1821void
1146e912 1822Perl_gv_check(pTHX_ const HV *stash)
79072805 1823{
97aff369 1824 dVAR;
79072805 1825 register I32 i;
463ee0b2 1826
7918f24d
NC
1827 PERL_ARGS_ASSERT_GV_CHECK;
1828
8990e307
LW
1829 if (!HvARRAY(stash))
1830 return;
a0d0e21e 1831 for (i = 0; i <= (I32) HvMAX(stash); i++) {
e1ec3a88 1832 const HE *entry;
dc437b57 1833 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
b7787f18
AL
1834 register GV *gv;
1835 HV *hv;
dc437b57 1836 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
159b6efe 1837 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
a0d0e21e 1838 {
19b6c847 1839 if (hv != PL_defstash && hv != stash)
a0d0e21e
LW
1840 gv_check(hv); /* nested package */
1841 }
dc437b57 1842 else if (isALPHA(*HeKEY(entry))) {
e1ec3a88 1843 const char *file;
159b6efe 1844 gv = MUTABLE_GV(HeVAL(entry));
55d729e4 1845 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
463ee0b2 1846 continue;
1d7c1841 1847 file = GvFILE(gv);
1d7c1841
GS
1848 CopLINE_set(PL_curcop, GvLINE(gv));
1849#ifdef USE_ITHREADS
dd374669 1850 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1d7c1841 1851#else
9bde8eb0
NC
1852 CopFILEGV(PL_curcop)
1853 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
1d7c1841 1854#endif
9014280d 1855 Perl_warner(aTHX_ packWARN(WARN_ONCE),
599cee73 1856 "Name \"%s::%s\" used only once: possible typo",
bfcb3514 1857 HvNAME_get(stash), GvNAME(gv));
463ee0b2 1858 }
79072805
LW
1859 }
1860 }
1861}
1862
1863GV *
e1ec3a88 1864Perl_newGVgen(pTHX_ const char *pack)
79072805 1865{
97aff369 1866 dVAR;
7918f24d
NC
1867
1868 PERL_ARGS_ASSERT_NEWGVGEN;
1869
cea2e8a9 1870 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
6fd99bb3 1871 GV_ADD, SVt_PVGV);
79072805
LW
1872}
1873
1874/* hopefully this is only called on local symbol table entries */
1875
1876GP*
864dbfa3 1877Perl_gp_ref(pTHX_ GP *gp)
79072805 1878{
97aff369 1879 dVAR;
1d7c1841 1880 if (!gp)
d4c19fe8 1881 return NULL;
79072805 1882 gp->gp_refcnt++;
44a8e56a
PP
1883 if (gp->gp_cv) {
1884 if (gp->gp_cvgen) {
e1a479c5
BB
1885 /* If the GP they asked for a reference to contains
1886 a method cache entry, clear it first, so that we
1887 don't infect them with our cached entry */
44a8e56a 1888 SvREFCNT_dec(gp->gp_cv);
601f1833 1889 gp->gp_cv = NULL;
44a8e56a
PP
1890 gp->gp_cvgen = 0;
1891 }
44a8e56a 1892 }
79072805 1893 return gp;
79072805
LW
1894}
1895
1896void
864dbfa3 1897Perl_gp_free(pTHX_ GV *gv)
79072805 1898{
97aff369 1899 dVAR;
79072805 1900 GP* gp;
b0d55c99 1901 int attempts = 100;
79072805 1902
f7877b28 1903 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
79072805 1904 return;
f248d071 1905 if (gp->gp_refcnt == 0) {
9b387841
NC
1906 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1907 "Attempt to free unreferenced glob pointers"
1908 pTHX__FORMAT pTHX__VALUE);
79072805
LW
1909 return;
1910 }
748a9306
LW
1911 if (--gp->gp_refcnt > 0) {
1912 if (gp->gp_egv == gv)
1913 gp->gp_egv = 0;
c43ae56f 1914 GvGP_set(gv, NULL);
79072805 1915 return;
748a9306 1916 }
79072805 1917
b0d55c99
FC
1918 while (1) {
1919 /* Copy and null out all the glob slots, so destructors do not see
1920 freed SVs. */
1921 HEK * const file_hek = gp->gp_file_hek;
1922 SV * const sv = gp->gp_sv;
1923 AV * const av = gp->gp_av;
1924 HV * const hv = gp->gp_hv;
1925 IO * const io = gp->gp_io;
1926 CV * const cv = gp->gp_cv;
1927 CV * const form = gp->gp_form;
1928
1929 gp->gp_file_hek = NULL;
1930 gp->gp_sv = NULL;
1931 gp->gp_av = NULL;
1932 gp->gp_hv = NULL;
1933 gp->gp_io = NULL;
1934 gp->gp_cv = NULL;
1935 gp->gp_form = NULL;
1936
1937 if (file_hek)
1938 unshare_hek(file_hek);
1939
1940 SvREFCNT_dec(sv);
1941 SvREFCNT_dec(av);
1942 /* FIXME - another reference loop GV -> symtab -> GV ?
1943 Somehow gp->gp_hv can end up pointing at freed garbage. */
1944 if (hv && SvTYPE(hv) == SVt_PVHV) {
1945 const char *hvname = HvNAME_get(hv);
bfcb3514 1946 if (PL_stashcache && hvname)
b0d55c99 1947 (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(hv),
7423f6db 1948 G_DISCARD);
b0d55c99
FC
1949 SvREFCNT_dec(hv);
1950 }
1951 SvREFCNT_dec(io);
1952 SvREFCNT_dec(cv);
1953 SvREFCNT_dec(form);
1954
1955 if (!gp->gp_file_hek
1956 && !gp->gp_sv
1957 && !gp->gp_av
1958 && !gp->gp_hv
1959 && !gp->gp_io
1960 && !gp->gp_cv
1961 && !gp->gp_form) break;
1962
1963 if (--attempts == 0) {
1964 Perl_die(aTHX_
1965 "panic: gp_free failed to free glob pointer - "
1966 "something is repeatedly re-creating entries"
1967 );
1968 }
13207a71 1969 }
748a9306 1970
79072805 1971 Safefree(gp);
c43ae56f 1972 GvGP_set(gv, NULL);
79072805
LW
1973}
1974
d460ef45
NIS
1975int
1976Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1977{
53c1dcc0
AL
1978 AMT * const amtp = (AMT*)mg->mg_ptr;
1979 PERL_UNUSED_ARG(sv);
dd374669 1980
7918f24d
NC
1981 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
1982
d460ef45
NIS
1983 if (amtp && AMT_AMAGIC(amtp)) {
1984 int i;
1985 for (i = 1; i < NofAMmeth; i++) {
53c1dcc0 1986 CV * const cv = amtp->table[i];
b37c2d43 1987 if (cv) {
ad64d0ec 1988 SvREFCNT_dec(MUTABLE_SV(cv));
601f1833 1989 amtp->table[i] = NULL;
d460ef45
NIS
1990 }
1991 }
1992 }
1993 return 0;
1994}
1995
a0d0e21e 1996/* Updates and caches the CV's */
c3a9a790
RGS
1997/* Returns:
1998 * 1 on success and there is some overload
1999 * 0 if there is no overload
2000 * -1 if some error occurred and it couldn't croak
2001 */
a0d0e21e 2002
c3a9a790 2003int
242f8760 2004Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
a0d0e21e 2005{
97aff369 2006 dVAR;
ad64d0ec 2007 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
a6006777 2008 AMT amt;
9b439311 2009 const struct mro_meta* stash_meta = HvMROMETA(stash);
e1a479c5 2010 U32 newgen;
a0d0e21e 2011
7918f24d
NC
2012 PERL_ARGS_ASSERT_GV_AMUPDATE;
2013
9b439311 2014 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
14899595
NC
2015 if (mg) {
2016 const AMT * const amtp = (AMT*)mg->mg_ptr;
2017 if (amtp->was_ok_am == PL_amagic_generation
e1a479c5 2018 && amtp->was_ok_sub == newgen) {
c3a9a790 2019 return AMT_OVERLOADED(amtp) ? 1 : 0;
14899595 2020 }
ad64d0ec 2021 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
14899595 2022 }
a0d0e21e 2023
bfcb3514 2024 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
a0d0e21e 2025
d460ef45 2026 Zero(&amt,1,AMT);
3280af22 2027 amt.was_ok_am = PL_amagic_generation;
e1a479c5 2028 amt.was_ok_sub = newgen;
a6006777
PP
2029 amt.fallback = AMGfallNO;
2030 amt.flags = 0;
2031
a6006777 2032 {
32251b26
IZ
2033 int filled = 0, have_ovl = 0;
2034 int i, lim = 1;
a6006777 2035
22c35a8c 2036 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
a6006777 2037
89ffc314 2038 /* Try to find via inheritance. */
53c1dcc0
AL
2039 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
2040 SV * const sv = gv ? GvSV(gv) : NULL;
2041 CV* cv;
89ffc314
IZ
2042
2043 if (!gv)
32251b26 2044 lim = DESTROY_amg; /* Skip overloading entries. */
c69033f2
NC
2045#ifdef PERL_DONT_CREATE_GVSV
2046 else if (!sv) {
6f207bd3 2047 NOOP; /* Equivalent to !SvTRUE and !SvOK */
c69033f2
NC
2048 }
2049#endif
89ffc314
IZ
2050 else if (SvTRUE(sv))
2051 amt.fallback=AMGfallYES;
2052 else if (SvOK(sv))
2053 amt.fallback=AMGfallNEVER;
a6006777 2054
32251b26 2055 for (i = 1; i < lim; i++)
601f1833 2056 amt.table[i] = NULL;
32251b26 2057 for (; i < NofAMmeth; i++) {
6136c704 2058 const char * const cooky = PL_AMG_names[i];
32251b26 2059 /* Human-readable form, for debugging: */
6136c704 2060 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
d279ab82 2061 const STRLEN l = PL_AMG_namelens[i];
89ffc314 2062
a0288114 2063 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
bfcb3514 2064 cp, HvNAME_get(stash)) );
611c1e95
IZ
2065 /* don't fill the cache while looking up!
2066 Creation of inheritance stubs in intermediate packages may
2067 conflict with the logic of runtime method substitution.
2068 Indeed, for inheritance A -> B -> C, if C overloads "+0",
2069 then we could have created stubs for "(+0" in A and C too.
2070 But if B overloads "bool", we may want to use it for
2071 numifying instead of C's "+0". */
2072 if (i >= DESTROY_amg)
2073 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
2074 else /* Autoload taken care of below */
2075 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
46fc3d4c 2076 cv = 0;
89ffc314 2077 if (gv && (cv = GvCV(gv))) {
f0e9f182
FC
2078 if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2079 const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2080 if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2081 && strEQ(hvname, "overload")) {
611c1e95
IZ
2082 /* This is a hack to support autoloading..., while
2083 knowing *which* methods were declared as overloaded. */
44a8e56a 2084 /* GvSV contains the name of the method. */
6136c704 2085 GV *ngv = NULL;
c69033f2 2086 SV *gvsv = GvSV(gv);
a0288114
AL
2087
2088 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2089 "\" for overloaded \"%s\" in package \"%.256s\"\n",
f0e9f182 2090 (void*)GvSV(gv), cp, HvNAME(stash)) );
c69033f2
NC
2091 if (!gvsv || !SvPOK(gvsv)
2092 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
dc848c6f
PP
2093 FALSE)))
2094 {
a0288114 2095 /* Can be an import stub (created by "can"). */
242f8760 2096 if (destructing) {
c3a9a790 2097 return -1;
242f8760
RGS
2098 }
2099 else {
2100 const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???";
2101 Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
2102 "in package \"%.256s\"",
2103 (GvCVGEN(gv) ? "Stub found while resolving"
2104 : "Can't resolve"),
f0e9f182 2105 name, cp, HvNAME(stash));
242f8760 2106 }
44a8e56a 2107 }
dc848c6f 2108 cv = GvCV(gv = ngv);
f0e9f182 2109 }
44a8e56a 2110 }
b464bac0 2111 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
bfcb3514 2112 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
44a8e56a
PP
2113 GvNAME(CvGV(cv))) );
2114 filled = 1;
32251b26
IZ
2115 if (i < DESTROY_amg)
2116 have_ovl = 1;
611c1e95 2117 } else if (gv) { /* Autoloaded... */
ea726b52 2118 cv = MUTABLE_CV(gv);
611c1e95 2119 filled = 1;
44a8e56a 2120 }
ea726b52 2121 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
a0d0e21e 2122 }
a0d0e21e 2123 if (filled) {
a6006777 2124 AMT_AMAGIC_on(&amt);
32251b26
IZ
2125 if (have_ovl)
2126 AMT_OVERLOADED_on(&amt);
ad64d0ec 2127 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
14befaf4 2128 (char*)&amt, sizeof(AMT));
32251b26 2129 return have_ovl;
a0d0e21e
LW
2130 }
2131 }
a6006777 2132 /* Here we have no table: */
9cbac4c7 2133 /* no_table: */
a6006777 2134 AMT_AMAGIC_off(&amt);
ad64d0ec 2135 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
14befaf4 2136 (char*)&amt, sizeof(AMTS));
c3a9a790 2137 return 0;
a0d0e21e
LW
2138}
2139
32251b26
IZ
2140
2141CV*
2142Perl_gv_handler(pTHX_ HV *stash, I32 id)
2143{
97aff369 2144 dVAR;
3f8f4626 2145 MAGIC *mg;
32251b26 2146 AMT *amtp;
e1a479c5 2147 U32 newgen;
9b439311 2148 struct mro_meta* stash_meta;
32251b26 2149
bfcb3514 2150 if (!stash || !HvNAME_get(stash))
601f1833 2151 return NULL;
e1a479c5 2152
9b439311
BB
2153 stash_meta = HvMROMETA(stash);
2154 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
e1a479c5 2155
ad64d0ec 2156 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
32251b26
IZ
2157 if (!mg) {
2158 do_update:
242f8760
RGS
2159 /* If we're looking up a destructor to invoke, we must avoid
2160 * that Gv_AMupdate croaks, because we might be dying already */
2dcac756 2161 if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
242f8760
RGS
2162 /* and if it didn't found a destructor, we fall back
2163 * to a simpler method that will only look for the
2164 * destructor instead of the whole magic */
2165 if (id == DESTROY_amg) {
2166 GV * const gv = gv_fetchmethod(stash, "DESTROY");
2167 if (gv)
2168 return GvCV(gv);
2169 }
2170 return NULL;
2171 }
ad64d0ec 2172 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
32251b26 2173 }
a9fd4e40 2174 assert(mg);
32251b26
IZ
2175 amtp = (AMT*)mg->mg_ptr;
2176 if ( amtp->was_ok_am != PL_amagic_generation
e1a479c5 2177 || amtp->was_ok_sub != newgen )
32251b26 2178 goto do_update;
3ad83ce7 2179 if (AMT_AMAGIC(amtp)) {
b7787f18 2180 CV * const ret = amtp->table[id];
3ad83ce7
AMS
2181 if (ret && isGV(ret)) { /* Autoloading stab */
2182 /* Passing it through may have resulted in a warning
2183 "Inherited AUTOLOAD for a non-method deprecated", since
2184 our caller is going through a function call, not a method call.
2185 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
890ce7af 2186 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
3ad83ce7
AMS
2187
2188 if (gv && GvCV(gv))
2189 return GvCV(gv);
2190 }
2191 return ret;
2192 }
a0288114 2193
601f1833 2194 return NULL;
32251b26
IZ
2195}
2196
2197
6f1401dc
DM
2198/* Implement tryAMAGICun_MG macro.
2199 Do get magic, then see if the stack arg is overloaded and if so call it.
2200 Flags:
2201 AMGf_set return the arg using SETs rather than assigning to
2202 the targ
2203 AMGf_numeric apply sv_2num to the stack arg.
2204*/
2205
2206bool
2207Perl_try_amagic_un(pTHX_ int method, int flags) {
2208 dVAR;
2209 dSP;
2210 SV* tmpsv;
2211 SV* const arg = TOPs;
2212
2213 SvGETMAGIC(arg);
2214
9f8bf298
NC
2215 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2216 AMGf_noright | AMGf_unary))) {
6f1401dc
DM
2217 if (flags & AMGf_set) {
2218 SETs(tmpsv);
2219 }
2220 else {
2221 dTARGET;
2222 if (SvPADMY(TARG)) {
2223 sv_setsv(TARG, tmpsv);
2224 SETTARG;
2225 }
2226 else
2227 SETs(tmpsv);
2228 }
2229 PUTBACK;
2230 return TRUE;
2231 }
2232
2233 if ((flags & AMGf_numeric) && SvROK(arg))
2234 *sp = sv_2num(arg);
2235 return FALSE;
2236}
2237
2238
2239/* Implement tryAMAGICbin_MG macro.
2240 Do get magic, then see if the two stack args are overloaded and if so
2241 call it.
2242 Flags:
2243 AMGf_set return the arg using SETs rather than assigning to
2244 the targ
2245 AMGf_assign op may be called as mutator (eg +=)
2246 AMGf_numeric apply sv_2num to the stack arg.
2247*/
2248
2249bool
2250Perl_try_amagic_bin(pTHX_ int method, int flags) {
2251 dVAR;
2252 dSP;
2253 SV* const left = TOPm1s;
2254 SV* const right = TOPs;
2255
2256 SvGETMAGIC(left);
2257 if (left != right)
2258 SvGETMAGIC(right);
2259
2260 if (SvAMAGIC(left) || SvAMAGIC(right)) {
2261 SV * const tmpsv = amagic_call(left, right, method,
2262 ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2263 if (tmpsv) {
2264 if (flags & AMGf_set) {
2265 (void)POPs;
2266 SETs(tmpsv);
2267 }
2268 else {
2269 dATARGET;
2270 (void)POPs;
2271 if (opASSIGN || SvPADMY(TARG)) {
2272 sv_setsv(TARG, tmpsv);
2273 SETTARG;
2274 }
2275 else
2276 SETs(tmpsv);
2277 }
2278 PUTBACK;
2279 return TRUE;
2280 }
2281 }
75ea7a12
FC
2282 if(left==right && SvGMAGICAL(left)) {
2283 SV * const left = sv_newmortal();
2284 *(sp-1) = left;
2285 /* Print the uninitialized warning now, so it includes the vari-
2286 able name. */
2287 if (!SvOK(right)) {
2288 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2289 sv_setsv_flags(left, &PL_sv_no, 0);
2290 }
2291 else sv_setsv_flags(left, right, 0);
2292 SvGETMAGIC(right);
2293 }
6f1401dc 2294 if (flags & AMGf_numeric) {
75ea7a12
FC
2295 if (SvROK(TOPm1s))
2296 *(sp-1) = sv_2num(TOPm1s);
6f1401dc
DM
2297 if (SvROK(right))
2298 *sp = sv_2num(right);
2299 }
2300 return FALSE;
2301}
2302
25a9ffce
NC
2303SV *
2304Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2305 SV *tmpsv = NULL;
2306
2307 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2308
2309 while (SvAMAGIC(ref) &&
2310 (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2311 AMGf_noright | AMGf_unary))) {
2312 if (!SvROK(tmpsv))
2313 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2314 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2315 /* Bail out if it returns us the same reference. */
2316 return tmpsv;
2317 }
2318 ref = tmpsv;
2319 }
2320 return tmpsv ? tmpsv : ref;
2321}
6f1401dc 2322
a0d0e21e 2323SV*
864dbfa3 2324Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
a0d0e21e 2325{
27da23d5 2326 dVAR;
b267980d 2327 MAGIC *mg;
9c5ffd7c 2328 CV *cv=NULL;
a0d0e21e 2329 CV **cvp=NULL, **ocvp=NULL;
9c5ffd7c 2330 AMT *amtp=NULL, *oamtp=NULL;
b464bac0
AL
2331 int off = 0, off1, lr = 0, notfound = 0;
2332 int postpr = 0, force_cpy = 0;
2333 int assign = AMGf_assign & flags;
2334 const int assignshift = assign ? 1 : 0;
bf5522a1 2335 int use_default_op = 0;
497b47a8
JH
2336#ifdef DEBUGGING
2337 int fl=0;
497b47a8 2338#endif
25716404 2339 HV* stash=NULL;
7918f24d
NC
2340
2341 PERL_ARGS_ASSERT_AMAGIC_CALL;
2342
e46c382e 2343 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
20439bc7 2344 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
e46c382e
YK
2345
2346 if ( !lex_mask || !SvOK(lex_mask) )
2347 /* overloading lexically disabled */
2348 return NULL;
2349 else if ( lex_mask && SvPOK(lex_mask) ) {
2350 /* we have an entry in the hints hash, check if method has been
2351 * masked by overloading.pm */
d15cd831 2352 STRLEN len;
e46c382e 2353 const int offset = method / 8;
d87d3eed 2354 const int bit = method % 8;
e46c382e
YK
2355 char *pv = SvPV(lex_mask, len);
2356
d15cd831 2357 /* Bit set, so this overloading operator is disabled */
ed15e576 2358 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
e46c382e
YK
2359 return NULL;
2360 }
2361 }
2362
a0d0e21e 2363 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
25716404 2364 && (stash = SvSTASH(SvRV(left)))
ad64d0ec 2365 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
b267980d 2366 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 2367 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
d4c19fe8 2368 : NULL))
b267980d 2369 && ((cv = cvp[off=method+assignshift])
748a9306
LW
2370 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2371 * usual method */
497b47a8
JH
2372 (
2373#ifdef DEBUGGING
2374 fl = 1,
a0288114 2375#endif
497b47a8 2376 cv = cvp[off=method])))) {
a0d0e21e
LW
2377 lr = -1; /* Call method for left argument */
2378 } else {
2379 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2380 int logic;
2381
2382 /* look for substituted methods */
ee239bfe 2383 /* In all the covered cases we should be called with assign==0. */
a0d0e21e
LW
2384 switch (method) {
2385 case inc_amg:
ee239bfe
IZ
2386 force_cpy = 1;
2387 if ((cv = cvp[off=add_ass_amg])
2388 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3280af22 2389 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
2390 }
2391 break;
2392 case dec_amg:
ee239bfe
IZ
2393 force_cpy = 1;
2394 if ((cv = cvp[off = subtr_ass_amg])
2395 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3280af22 2396 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
2397 }
2398 break;
2399 case bool__amg:
2400 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2401 break;
2402 case numer_amg:
2403 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2404 break;
2405 case string_amg:
2406 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2407 break;
b7787f18
AL
2408 case not_amg:
2409 (void)((cv = cvp[off=bool__amg])
2410 || (cv = cvp[off=numer_amg])
2411 || (cv = cvp[off=string_amg]));
2ab54efd
MB
2412 if (cv)
2413 postpr = 1;
b7787f18 2414 break;
748a9306
LW
2415 case copy_amg:
2416 {
76e3520e
GS
2417 /*
2418 * SV* ref causes confusion with the interpreter variable of
2419 * the same name
2420 */
890ce7af 2421 SV* const tmpRef=SvRV(left);
76e3520e 2422 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
fc36a67e
PP
2423 /*
2424 * Just to be extra cautious. Maybe in some
2425 * additional cases sv_setsv is safe, too.
2426 */
890ce7af 2427 SV* const newref = newSVsv(tmpRef);
748a9306 2428 SvOBJECT_on(newref);
96d4b0ee
NC
2429 /* As a bit of a source compatibility hack, SvAMAGIC() and
2430 friends dereference an RV, to behave the same was as when
2431 overloading was stored on the reference, not the referant.
2432 Hence we can't use SvAMAGIC_on()
2433 */
2434 SvFLAGS(newref) |= SVf_AMAGIC;
85fbaab2 2435 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
748a9306
LW
2436 return newref;
2437 }
2438 }
2439 break;
a0d0e21e 2440 case abs_amg:
b267980d 2441 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
a0d0e21e 2442 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
890ce7af 2443 SV* const nullsv=sv_2mortal(newSViv(0));
a0d0e21e 2444 if (off1==lt_amg) {
890ce7af 2445 SV* const lessp = amagic_call(left,nullsv,
a0d0e21e
LW
2446 lt_amg,AMGf_noright);
2447 logic = SvTRUE(lessp);
2448 } else {
890ce7af 2449 SV* const lessp = amagic_call(left,nullsv,
a0d0e21e
LW
2450 ncmp_amg,AMGf_noright);
2451 logic = (SvNV(lessp) < 0);
2452 }
2453 if (logic) {
2454 if (off==subtr_amg) {
2455 right = left;
748a9306 2456 left = nullsv;
a0d0e21e
LW
2457 lr = 1;
2458 }
2459 } else {
2460 return left;
2461 }
2462 }
2463 break;
2464 case neg_amg:
155aba94 2465 if ((cv = cvp[off=subtr_amg])) {
a0d0e21e
LW
2466 right = left;
2467 left = sv_2mortal(newSViv(0));
2468 lr = 1;
2469 }
2470 break;
f216259d 2471 case int_amg:
f5284f61 2472 case iter_amg: /* XXXX Eventually should do to_gv. */
c4c7412c 2473 case ftest_amg: /* XXXX Eventually should do to_gv. */
d4b87e75 2474 case regexp_amg:
b267980d
NIS
2475 /* FAIL safe */
2476 return NULL; /* Delegate operation to standard mechanisms. */
2477 break;
f5284f61
IZ
2478 case to_sv_amg:
2479 case to_av_amg:
2480 case to_hv_amg:
2481 case to_gv_amg:
2482 case to_cv_amg:
2483 /* FAIL safe */
b267980d 2484 return left; /* Delegate operation to standard mechanisms. */
f5284f61 2485 break;
a0d0e21e
LW
2486 default:
2487 goto not_found;
2488 }
2489 if (!cv) goto not_found;
2490 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
25716404 2491 && (stash = SvSTASH(SvRV(right)))
ad64d0ec 2492 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
b267980d 2493 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 2494 ? (amtp = (AMT*)mg->mg_ptr)->table
d4c19fe8 2495 : NULL))
a0d0e21e
LW
2496 && (cv = cvp[off=method])) { /* Method for right
2497 * argument found */
2498 lr=1;
bf5522a1
MB
2499 } else if (((cvp && amtp->fallback > AMGfallNEVER)
2500 || (ocvp && oamtp->fallback > AMGfallNEVER))
a0d0e21e
LW
2501 && !(flags & AMGf_unary)) {
2502 /* We look for substitution for
2503 * comparison operations and
fc36a67e 2504 * concatenation */
a0d0e21e
LW
2505 if (method==concat_amg || method==concat_ass_amg
2506 || method==repeat_amg || method==repeat_ass_amg) {
2507 return NULL; /* Delegate operation to string conversion */
2508 }
2509 off = -1;
2510 switch (method) {
2511 case lt_amg:
2512 case le_amg:
2513 case gt_amg:
2514 case ge_amg:
2515 case eq_amg:
2516 case ne_amg:
2ab54efd
MB
2517 off = ncmp_amg;
2518 break;
a0d0e21e
LW
2519 case slt_amg:
2520 case sle_amg:
2521 case sgt_amg:
2522 case sge_amg:
2523 case seq_amg:
2524 case sne_amg:
2ab54efd
MB
2525 off = scmp_amg;
2526 break;
a0d0e21e 2527 }
bf5522a1
MB
2528 if (off != -1) {
2529 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2530 cv = ocvp[off];
2531 lr = -1;
2532 }
2533 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2534 cv = cvp[off];
2535 lr = 1;
2536 }
2537 }
2538 if (cv)
2ab54efd
MB
2539 postpr = 1;
2540 else
2541 goto not_found;
a0d0e21e 2542 } else {
a6006777 2543 not_found: /* No method found, either report or croak */
b267980d
NIS
2544 switch (method) {
2545 case to_sv_amg:
2546 case to_av_amg:
2547 case to_hv_amg:
2548 case to_gv_amg:
2549 case to_cv_amg:
2550 /* FAIL safe */
2551 return left; /* Delegate operation to standard mechanisms. */
2552 break;
2553 }
a0d0e21e
LW
2554 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2555 notfound = 1; lr = -1;
2556 } else if (cvp && (cv=cvp[nomethod_amg])) {
2557 notfound = 1; lr = 1;
bf5522a1
MB
2558 } else if ((use_default_op =
2559 (!ocvp || oamtp->fallback >= AMGfallYES)
2560 && (!cvp || amtp->fallback >= AMGfallYES))
2561 && !DEBUG_o_TEST) {
4cc0ca18
NC
2562 /* Skip generating the "no method found" message. */
2563 return NULL;
a0d0e21e 2564 } else {
46fc3d4c 2565 SV *msg;
774d564b 2566 if (off==-1) off=method;
b267980d 2567 msg = sv_2mortal(Perl_newSVpvf(aTHX_
a0288114 2568 "Operation \"%s\": no method found,%sargument %s%s%s%s",
89ffc314 2569 AMG_id2name(method + assignshift),
e7ea3e70 2570 (flags & AMGf_unary ? " " : "\n\tleft "),
b267980d 2571 SvAMAGIC(left)?
a0d0e21e
LW
2572 "in overloaded package ":
2573 "has no overloaded magic",
b267980d 2574 SvAMAGIC(left)?
bfcb3514 2575 HvNAME_get(SvSTASH(SvRV(left))):
a0d0e21e 2576 "",
b267980d 2577 SvAMAGIC(right)?
e7ea3e70 2578 ",\n\tright argument in overloaded package ":
b267980d 2579 (flags & AMGf_unary
e7ea3e70
IZ
2580 ? ""
2581 : ",\n\tright argument has no overloaded magic"),
b267980d 2582 SvAMAGIC(right)?
bfcb3514 2583 HvNAME_get(SvSTASH(SvRV(right))):
46fc3d4c 2584 ""));
bf5522a1 2585 if (use_default_op) {
b15aece3 2586 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
a0d0e21e 2587 } else {
be2597df 2588 Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
a0d0e21e
LW
2589 }
2590 return NULL;
2591 }
ee239bfe 2592 force_cpy = force_cpy || assign;
a0d0e21e
LW
2593 }
2594 }
497b47a8 2595#ifdef DEBUGGING
a0d0e21e 2596 if (!notfound) {
497b47a8 2597 DEBUG_o(Perl_deb(aTHX_
a0288114 2598 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
497b47a8
JH
2599 AMG_id2name(off),
2600 method+assignshift==off? "" :
a0288114 2601 " (initially \"",
497b47a8
JH
2602 method+assignshift==off? "" :
2603 AMG_id2name(method+assignshift),
a0288114 2604 method+assignshift==off? "" : "\")",
497b47a8
JH
2605 flags & AMGf_unary? "" :
2606 lr==1 ? " for right argument": " for left argument",
2607 flags & AMGf_unary? " for argument" : "",
bfcb3514 2608 stash ? HvNAME_get(stash) : "null",
497b47a8 2609 fl? ",\n\tassignment variant used": "") );
ee239bfe 2610 }
497b47a8 2611#endif
748a9306
LW
2612 /* Since we use shallow copy during assignment, we need
2613 * to dublicate the contents, probably calling user-supplied
2614 * version of copy operator
2615 */
ee239bfe
IZ
2616 /* We need to copy in following cases:
2617 * a) Assignment form was called.
2618 * assignshift==1, assign==T, method + 1 == off
2619 * b) Increment or decrement, called directly.
2620 * assignshift==0, assign==0, method + 0 == off
2621 * c) Increment or decrement, translated to assignment add/subtr.
b267980d 2622 * assignshift==0, assign==T,
ee239bfe
IZ
2623 * force_cpy == T
2624 * d) Increment or decrement, translated to nomethod.
b267980d 2625 * assignshift==0, assign==0,
ee239bfe
IZ
2626 * force_cpy == T
2627 * e) Assignment form translated to nomethod.
2628 * assignshift==1, assign==T, method + 1 != off
2629 * force_cpy == T
2630 */
2631 /* off is method, method+assignshift, or a result of opcode substitution.
2632 * In the latter case assignshift==0, so only notfound case is important.
2633 */
2634 if (( (method + assignshift == off)
2635 && (assign || (method == inc_amg) || (method == dec_amg)))
2636 || force_cpy)
6f1401dc 2637 {
1b38c28e
NC
2638 /* newSVsv does not behave as advertised, so we copy missing
2639 * information by hand */
2640 SV *tmpRef = SvRV(left);
2641 SV *rv_copy;
31d632c3 2642 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
1b38c28e
NC
2643 SvRV_set(left, rv_copy);
2644 SvSETMAGIC(left);
2645 SvREFCNT_dec(tmpRef);
2646 }
6f1401dc
DM
2647 }
2648
a0d0e21e
LW
2649 {
2650 dSP;
2651 BINOP myop;
2652 SV* res;
b7787f18 2653 const bool oldcatch = CATCH_GET;
a0d0e21e 2654
54310121 2655 CATCH_SET(TRUE);
a0d0e21e
LW
2656 Zero(&myop, 1, BINOP);
2657 myop.op_last = (OP *) &myop;
b37c2d43 2658 myop.op_next = NULL;
54310121 2659 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
a0d0e21e 2660
e788e7d3 2661 PUSHSTACKi(PERLSI_OVERLOAD);
a0d0e21e 2662 ENTER;
462e5cf6 2663 SAVEOP();
533c011a 2664 PL_op = (OP *) &myop;
3280af22 2665 if (PERLDB_SUB && PL_curstash != PL_debstash)
533c011a 2666 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 2667 PUTBACK;
897d3989 2668 Perl_pp_pushmark(aTHX);
a0d0e21e 2669
924508f0 2670 EXTEND(SP, notfound + 5);
a0d0e21e
LW
2671 PUSHs(lr>0? right: left);
2672 PUSHs(lr>0? left: right);
3280af22 2673 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
a0d0e21e 2674 if (notfound) {
59cd0e26
NC
2675 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2676 AMG_id2namelen(method + assignshift), SVs_TEMP));
a0d0e21e 2677 }
ad64d0ec 2678 PUSHs(MUTABLE_SV(cv));
a0d0e21e
LW
2679 PUTBACK;
2680
139d0ce6 2681 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
cea2e8a9 2682 CALLRUNOPS(aTHX);
a0d0e21e
LW
2683 LEAVE;
2684 SPAGAIN;
2685
2686 res=POPs;
ebafeae7 2687 PUTBACK;
d3acc0f7 2688 POPSTACK;
54310121 2689 CATCH_SET(oldcatch);
a0d0e21e 2690
a0d0e21e 2691 if (postpr) {
b7787f18 2692 int ans;
a0d0e21e
LW
2693 switch (method) {
2694 case le_amg:
2695 case sle_amg:
2696 ans=SvIV(res)<=0; break;
2697 case lt_amg:
2698 case slt_amg:
2699 ans=SvIV(res)<0; break;
2700 case ge_amg:
2701 case sge_amg:
2702 ans=SvIV(res)>=0; break;
2703 case gt_amg:
2704 case sgt_amg:
2705 ans=SvIV(res)>0; break;
2706 case eq_amg:
2707 case seq_amg:
2708 ans=SvIV(res)==0; break;
2709 case ne_amg:
2710 case sne_amg:
2711 ans=SvIV(res)!=0; break;
2712 case inc_amg:
2713 case dec_amg:
bbce6d69 2714 SvSetSV(left,res); return left;
dc437b57 2715 case not_amg:
fe7ac86a 2716 ans=!SvTRUE(res); break;
b7787f18
AL
2717 default:
2718 ans=0; break;
a0d0e21e 2719 }
54310121 2720 return boolSV(ans);
748a9306
LW
2721 } else if (method==copy_amg) {
2722 if (!SvROK(res)) {
cea2e8a9 2723 Perl_croak(aTHX_ "Copy method did not return a reference");
748a9306
LW
2724 }
2725 return SvREFCNT_inc(SvRV(res));
a0d0e21e
LW
2726 } else {
2727 return res;
2728 }
2729 }
2730}
c9d5ac95 2731
f5c1e807
NC
2732void
2733Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2734{
2735 dVAR;
acda4c6a 2736 U32 hash;
f5c1e807 2737
7918f24d 2738 PERL_ARGS_ASSERT_GV_NAME_SET;
f5c1e807
NC
2739 PERL_UNUSED_ARG(flags);
2740
acda4c6a
NC
2741 if (len > I32_MAX)
2742 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2743
ae8cc45f
NC
2744 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2745 unshare_hek(GvNAME_HEK(gv));
2746 }
2747
acda4c6a 2748 PERL_HASH(hash, name, len);
9f616d01 2749 GvNAME_HEK(gv) = share_hek(name, len, hash);
f5c1e807
NC
2750}
2751
66610fdd 2752/*
f7461760
Z
2753=for apidoc gv_try_downgrade
2754
2867cdbc
Z
2755If the typeglob C<gv> can be expressed more succinctly, by having
2756something other than a real GV in its place in the stash, replace it
2757with the optimised form. Basic requirements for this are that C<gv>
2758is a real typeglob, is sufficiently ordinary, and is only referenced
2759from its package. This function is meant to be used when a GV has been
2760looked up in part to see what was there, causing upgrading, but based
2761on what was found it turns out that the real GV isn't required after all.
2762
2763If C<gv> is a completely empty typeglob, it is deleted from the stash.
2764
2765If C<gv> is a typeglob containing only a sufficiently-ordinary constant
2766sub, the typeglob is replaced with a scalar-reference placeholder that
2767more compactly represents the same thing.
f7461760
Z
2768
2769=cut
2770*/
2771
2772void
2773Perl_gv_try_downgrade(pTHX_ GV *gv)
2774{
2775 HV *stash;
2776 CV *cv;
2777 HEK *namehek;
2778 SV **gvp;
2779 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
95f56751
FC
2780
2781 /* XXX Why and where does this leave dangling pointers during global
2782 destruction? */
627364f1 2783 if (PL_phase == PERL_PHASE_DESTRUCT) return;
95f56751 2784
2867cdbc 2785 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
803f2748 2786 !SvOBJECT(gv) && !SvREADONLY(gv) &&
f7461760 2787 isGV_with_GP(gv) && GvGP(gv) &&
2867cdbc 2788 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
f7461760 2789 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
099be4f1 2790 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
2867cdbc 2791 return;
803f2748
DM
2792 if (SvMAGICAL(gv)) {
2793 MAGIC *mg;
2794 /* only backref magic is allowed */
2795 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
2796 return;
2797 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
2798 if (mg->mg_type != PERL_MAGIC_backref)
2799 return;
2800 }
2801 }
2867cdbc
Z
2802 cv = GvCV(gv);
2803 if (!cv) {
2804 HEK *gvnhek = GvNAME_HEK(gv);
2805 (void)hv_delete(stash, HEK_KEY(gvnhek),
2806 HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
2807 } else if (GvMULTI(gv) && cv &&
f7461760
Z
2808 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
2809 CvSTASH(cv) == stash && CvGV(cv) == gv &&
2810 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
2811 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
2812 (namehek = GvNAME_HEK(gv)) &&
2813 (gvp = hv_fetch(stash, HEK_KEY(namehek),
2814 HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
2815 *gvp == (SV*)gv) {
2816 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
2817 SvREFCNT(gv) = 0;
2818 sv_clear((SV*)gv);
2819 SvREFCNT(gv) = 1;
2820 SvFLAGS(gv) = SVt_IV|SVf_ROK;
2821 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
2822 STRUCT_OFFSET(XPVIV, xiv_iv));
2823 SvRV_set(gv, value);
2824 }
2825}
2826
4aaa4757
FC
2827#include "XSUB.h"
2828
2829static void
2830core_xsub(pTHX_ CV* cv)
2831{
2832 Perl_croak(aTHX_
2833 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
2834 );
2835}
2836
f7461760 2837/*
66610fdd
RGS
2838 * Local variables:
2839 * c-indentation-style: bsd
2840 * c-basic-offset: 4
2841 * indent-tabs-mode: t
2842 * End:
2843 *
37442d52
RGS
2844 * ex: set ts=8 sts=4 sw=4 noet:
2845 */