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