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