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