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