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