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