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