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