This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Refactoring to Sv*_set() macros - patch #5
[perl5.git] / gv.c
CommitLineData
a0d0e21e 1/* gv.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
9431620d 4 * 2000, 2001, 2002, 2003, 2004, 2005, 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
13 * of your inquisitiveness, I shall spend all the rest of my days answering
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.
79072805
LW
18 */
19
ccfc67b7
JH
20/*
21=head1 GV Functions
166f8a29
DM
22
23A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
24It is a structure that holds a pointer to a scalar, an array, a hash etc,
25corresponding to $foo, @foo, %foo.
26
27GVs are usually found as values in stashes (symbol table hashes) where
28Perl stores its global variables.
29
30=cut
ccfc67b7
JH
31*/
32
79072805 33#include "EXTERN.h"
864dbfa3 34#define PERL_IN_GV_C
79072805
LW
35#include "perl.h"
36
37GV *
864dbfa3 38Perl_gv_AVadd(pTHX_ register GV *gv)
79072805 39{
a0d0e21e 40 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
cea2e8a9 41 Perl_croak(aTHX_ "Bad symbol for array");
79072805
LW
42 if (!GvAV(gv))
43 GvAV(gv) = newAV();
44 return gv;
45}
46
47GV *
864dbfa3 48Perl_gv_HVadd(pTHX_ register GV *gv)
79072805 49{
a0d0e21e 50 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
cea2e8a9 51 Perl_croak(aTHX_ "Bad symbol for hash");
79072805 52 if (!GvHV(gv))
463ee0b2 53 GvHV(gv) = newHV();
79072805
LW
54 return gv;
55}
56
57GV *
864dbfa3 58Perl_gv_IOadd(pTHX_ register GV *gv)
a0d0e21e
LW
59{
60 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
cea2e8a9 61 Perl_croak(aTHX_ "Bad symbol for filehandle");
5bd07a3d 62 if (!GvIOp(gv)) {
7fb37951
AMS
63#ifdef GV_UNIQUE_CHECK
64 if (GvUNIQUE(gv)) {
65 Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
5bd07a3d
DM
66 }
67#endif
a0d0e21e 68 GvIOp(gv) = newIO();
5bd07a3d 69 }
a0d0e21e
LW
70 return gv;
71}
72
73GV *
864dbfa3 74Perl_gv_fetchfile(pTHX_ const char *name)
79072805 75{
eacec437 76 char smallbuf[256];
53d95988 77 char *tmpbuf;
8ebc5c01 78 STRLEN tmplen;
79072805
LW
79 GV *gv;
80
1d7c1841
GS
81 if (!PL_defstash)
82 return Nullgv;
83
53d95988
CS
84 tmplen = strlen(name) + 2;
85 if (tmplen < sizeof smallbuf)
86 tmpbuf = smallbuf;
87 else
88 New(603, tmpbuf, tmplen + 1, char);
0ac0412a 89 /* This is where the debugger's %{"::_<$filename"} hash is created */
53d95988
CS
90 tmpbuf[0] = '_';
91 tmpbuf[1] = '<';
92 strcpy(tmpbuf + 2, name);
3280af22 93 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
1d7c1841 94 if (!isGV(gv)) {
3280af22 95 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
1d7c1841
GS
96 sv_setpv(GvSV(gv), name);
97 if (PERLDB_LINE)
14befaf4 98 hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile);
1d7c1841 99 }
53d95988
CS
100 if (tmpbuf != smallbuf)
101 Safefree(tmpbuf);
79072805
LW
102 return gv;
103}
104
463ee0b2 105void
864dbfa3 106Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
463ee0b2
LW
107{
108 register GP *gp;
e1ec3a88 109 const bool doproto = SvTYPE(gv) > SVt_NULL;
55d729e4 110 char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
463ee0b2 111
dc437b57 112 sv_upgrade((SV*)gv, SVt_PVGV);
55d729e4
GS
113 if (SvLEN(gv)) {
114 if (proto) {
f880fe2f 115 SvPV_set(gv, NULL);
b162af07 116 SvLEN_set(gv, 0);
55d729e4
GS
117 SvPOK_off(gv);
118 } else
119 Safefree(SvPVX(gv));
120 }
44a8e56a 121 Newz(602, gp, 1, GP);
8990e307 122 GvGP(gv) = gp_ref(gp);
463ee0b2 123 GvSV(gv) = NEWSV(72,0);
1d7c1841 124 GvLINE(gv) = CopLINE(PL_curcop);
07409e01
NC
125 /* XXX Ideally this cast would be replaced with a change to const char*
126 in the struct. */
127 GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : (char *) "";
005a453c 128 GvCVGEN(gv) = 0;
463ee0b2 129 GvEGV(gv) = gv;
14befaf4 130 sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
85aff577 131 GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
a0d0e21e 132 GvNAME(gv) = savepvn(name, len);
463ee0b2 133 GvNAMELEN(gv) = len;
23ad5bf5 134 if (multi || doproto) /* doproto means it _was_ mentioned */
a5f75d66 135 GvMULTI_on(gv);
55d729e4 136 if (doproto) { /* Replicate part of newSUB here. */
57ff9a15 137 SvIOK_off(gv);
55d729e4 138 ENTER;
b099ddc0 139 /* XXX unsafe for threads if eval_owner isn't held */
55d729e4 140 start_subparse(0,0); /* Create CV in compcv. */
3280af22 141 GvCV(gv) = PL_compcv;
55d729e4
GS
142 LEAVE;
143
3280af22 144 PL_sub_generation++;
65c50114 145 CvGV(GvCV(gv)) = gv;
e0d088d0 146 CvFILE_set_from_cop(GvCV(gv), PL_curcop);
3280af22 147 CvSTASH(GvCV(gv)) = PL_curstash;
55d729e4
GS
148 if (proto) {
149 sv_setpv((SV*)GvCV(gv), proto);
150 Safefree(proto);
151 }
152 }
463ee0b2
LW
153}
154
76e3520e 155STATIC void
cea2e8a9 156S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
a0d0e21e
LW
157{
158 switch (sv_type) {
159 case SVt_PVIO:
160 (void)GvIOn(gv);
161 break;
162 case SVt_PVAV:
163 (void)GvAVn(gv);
164 break;
165 case SVt_PVHV:
166 (void)GvHVn(gv);
167 break;
168 }
169}
170
954c1994
GS
171/*
172=for apidoc gv_fetchmeth
173
174Returns the glob with the given C<name> and a defined subroutine or
175C<NULL>. The glob lives in the given C<stash>, or in the stashes
07766739 176accessible via @ISA and UNIVERSAL::.
954c1994
GS
177
178The argument C<level> should be either 0 or -1. If C<level==0>, as a
179side-effect creates a glob with the given C<name> in the given C<stash>
180which in the case of success contains an alias for the subroutine, and sets
b267980d 181up caching info for this glob. Similarly for all the searched stashes.
954c1994
GS
182
183This function grants C<"SUPER"> token as a postfix of the stash name. The
184GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
4929bf7b 185visible to Perl code. So when calling C<call_sv>, you should not use
954c1994 186the GV directly; instead, you should use the method's CV, which can be
b267980d 187obtained from the GV with the C<GvCV> macro.
954c1994
GS
188
189=cut
190*/
191
79072805 192GV *
864dbfa3 193Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
79072805
LW
194{
195 AV* av;
463ee0b2 196 GV* topgv;
79072805 197 GV* gv;
463ee0b2 198 GV** gvp;
748a9306 199 CV* cv;
a0d0e21e 200
af09ea45
IK
201 /* UNIVERSAL methods should be callable without a stash */
202 if (!stash) {
203 level = -1; /* probably appropriate */
204 if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE)))
205 return 0;
206 }
207
e27ad1f2
AV
208 if (!HvNAME(stash))
209 Perl_croak(aTHX_
210 "Can't use anonymous symbol table for method lookup");
211
44a8e56a 212 if ((level > 100) || (level < -100))
cea2e8a9 213 Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
3e0ccd42 214 name, HvNAME(stash));
463ee0b2 215
cea2e8a9 216 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
44a8e56a
PP
217
218 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
219 if (!gvp)
220 topgv = Nullgv;
221 else {
222 topgv = *gvp;
223 if (SvTYPE(topgv) != SVt_PVGV)
224 gv_init(topgv, stash, name, len, TRUE);
155aba94 225 if ((cv = GvCV(topgv))) {
44a8e56a 226 /* If genuine method or valid cache entry, use it */
3280af22 227 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
7a4c00b4 228 return topgv;
44a8e56a
PP
229 /* Stale cached entry: junk it */
230 SvREFCNT_dec(cv);
231 GvCV(topgv) = cv = Nullcv;
232 GvCVGEN(topgv) = 0;
748a9306 233 }
3280af22 234 else if (GvCVGEN(topgv) == PL_sub_generation)
005a453c 235 return 0; /* cache indicates sub doesn't exist */
463ee0b2 236 }
79072805 237
9607fc9c 238 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
3280af22 239 av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
9607fc9c 240
fb73857a
PP
241 /* create and re-create @.*::SUPER::ISA on demand */
242 if (!av || !SvMAGIC(av)) {
9607fc9c
PP
243 char* packname = HvNAME(stash);
244 STRLEN packlen = strlen(packname);
245
246 if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
247 HV* basestash;
248
249 packlen -= 7;
250 basestash = gv_stashpvn(packname, packlen, TRUE);
251 gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
3280af22 252 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
9607fc9c
PP
253 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
254 if (!gvp || !(gv = *gvp))
cea2e8a9 255 Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
9607fc9c
PP
256 if (SvTYPE(gv) != SVt_PVGV)
257 gv_init(gv, stash, "ISA", 3, TRUE);
258 SvREFCNT_dec(GvAV(gv));
259 GvAV(gv) = (AV*)SvREFCNT_inc(av);
260 }
261 }
262 }
263
264 if (av) {
79072805 265 SV** svp = AvARRAY(av);
93965878
NIS
266 /* NOTE: No support for tied ISA */
267 I32 items = AvFILLp(av) + 1;
79072805 268 while (items--) {
79072805 269 SV* sv = *svp++;
a0d0e21e 270 HV* basestash = gv_stashsv(sv, FALSE);
9bbf4081 271 if (!basestash) {
599cee73 272 if (ckWARN(WARN_MISC))
35c1215d
NC
273 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
274 sv, HvNAME(stash));
79072805
LW
275 continue;
276 }
44a8e56a
PP
277 gv = gv_fetchmeth(basestash, name, len,
278 (level >= 0) ? level + 1 : level - 1);
279 if (gv)
280 goto gotcha;
79072805
LW
281 }
282 }
a0d0e21e 283
9607fc9c
PP
284 /* if at top level, try UNIVERSAL */
285
44a8e56a 286 if (level == 0 || level == -1) {
9607fc9c
PP
287 HV* lastchance;
288
155aba94
GS
289 if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
290 if ((gv = gv_fetchmeth(lastchance, name, len,
291 (level >= 0) ? level + 1 : level - 1)))
292 {
44a8e56a 293 gotcha:
dc848c6f
PP
294 /*
295 * Cache method in topgv if:
296 * 1. topgv has no synonyms (else inheritance crosses wires)
297 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
298 */
299 if (topgv &&
300 GvREFCNT(topgv) == 1 &&
301 (cv = GvCV(gv)) &&
302 (CvROOT(cv) || CvXSUB(cv)))
303 {
155aba94 304 if ((cv = GvCV(topgv)))
44a8e56a
PP
305 SvREFCNT_dec(cv);
306 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
3280af22 307 GvCVGEN(topgv) = PL_sub_generation;
44a8e56a 308 }
a0d0e21e
LW
309 return gv;
310 }
005a453c
JP
311 else if (topgv && GvREFCNT(topgv) == 1) {
312 /* cache the fact that the method is not defined */
3280af22 313 GvCVGEN(topgv) = PL_sub_generation;
005a453c 314 }
a0d0e21e
LW
315 }
316 }
317
79072805
LW
318 return 0;
319}
320
954c1994 321/*
611c1e95
IZ
322=for apidoc gv_fetchmeth_autoload
323
324Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
325Returns a glob for the subroutine.
326
327For an autoloaded subroutine without a GV, will create a GV even
328if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
329of the result may be zero.
330
331=cut
332*/
333
334GV *
335Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
336{
337 GV *gv = gv_fetchmeth(stash, name, len, level);
338
339 if (!gv) {
340 char autoload[] = "AUTOLOAD";
341 STRLEN autolen = sizeof(autoload)-1;
342 CV *cv;
343 GV **gvp;
344
345 if (!stash)
346 return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */
347 if (len == autolen && strnEQ(name, autoload, autolen))
348 return Nullgv;
349 if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
350 return Nullgv;
351 cv = GvCV(gv);
352 if (!(CvROOT(cv) || CvXSUB(cv)))
353 return Nullgv;
354 /* Have an autoload */
355 if (level < 0) /* Cannot do without a stub */
356 gv_fetchmeth(stash, name, len, 0);
357 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
358 if (!gvp)
359 return Nullgv;
360 return *gvp;
361 }
362 return gv;
363}
364
365/*
954c1994
GS
366=for apidoc gv_fetchmethod
367
6d0f518e 368See L<gv_fetchmethod_autoload>.
954c1994
GS
369
370=cut
371*/
372
79072805 373GV *
864dbfa3 374Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
463ee0b2 375{
dc848c6f
PP
376 return gv_fetchmethod_autoload(stash, name, TRUE);
377}
378
954c1994
GS
379/*
380=for apidoc gv_fetchmethod_autoload
381
382Returns the glob which contains the subroutine to call to invoke the method
383on the C<stash>. In fact in the presence of autoloading this may be the
384glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
b267980d 385already setup.
954c1994
GS
386
387The third parameter of C<gv_fetchmethod_autoload> determines whether
388AUTOLOAD lookup is performed if the given method is not present: non-zero
b267980d 389means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
954c1994 390Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
b267980d 391with a non-zero C<autoload> parameter.
954c1994
GS
392
393These functions grant C<"SUPER"> token as a prefix of the method name. Note
394that if you want to keep the returned glob for a long time, you need to
395check for it being "AUTOLOAD", since at the later time the call may load a
396different subroutine due to $AUTOLOAD changing its value. Use the glob
b267980d 397created via a side effect to do this.
954c1994
GS
398
399These functions have the same side-effects and as C<gv_fetchmeth> with
400C<level==0>. C<name> should be writable if contains C<':'> or C<'
401''>. The warning against passing the GV returned by C<gv_fetchmeth> to
b267980d 402C<call_sv> apply equally to these functions.
954c1994
GS
403
404=cut
405*/
406
dc848c6f 407GV *
864dbfa3 408Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
dc848c6f 409{
08105a92
GS
410 register const char *nend;
411 const char *nsplit = 0;
a0d0e21e 412 GV* gv;
0dae17bd
GS
413 HV* ostash = stash;
414
415 if (stash && SvTYPE(stash) < SVt_PVHV)
416 stash = Nullhv;
b267980d 417
463ee0b2 418 for (nend = name; *nend; nend++) {
9607fc9c 419 if (*nend == '\'')
a0d0e21e 420 nsplit = nend;
9607fc9c
PP
421 else if (*nend == ':' && *(nend + 1) == ':')
422 nsplit = ++nend;
a0d0e21e
LW
423 }
424 if (nsplit) {
08105a92 425 const char *origname = name;
a0d0e21e 426 name = nsplit + 1;
a0d0e21e
LW
427 if (*nsplit == ':')
428 --nsplit;
9607fc9c
PP
429 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
430 /* ->SUPER::method should really be looked up in original stash */
cea2e8a9 431 SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
1d7c1841 432 CopSTASHPV(PL_curcop)));
af09ea45 433 /* __PACKAGE__::SUPER stash should be autovivified */
9607fc9c 434 stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
cea2e8a9 435 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
9607fc9c 436 origname, HvNAME(stash), name) );
4633a7c4 437 }
e189a56d 438 else {
af09ea45
IK
439 /* don't autovifify if ->NoSuchStash::method */
440 stash = gv_stashpvn(origname, nsplit - origname, FALSE);
e189a56d
IK
441
442 /* however, explicit calls to Pkg::SUPER::method may
443 happen, and may require autovivification to work */
444 if (!stash && (nsplit - origname) >= 7 &&
445 strnEQ(nsplit - 7, "::SUPER", 7) &&
446 gv_stashpvn(origname, nsplit - origname - 7, FALSE))
447 stash = gv_stashpvn(origname, nsplit - origname, TRUE);
448 }
0dae17bd 449 ostash = stash;
4633a7c4
LW
450 }
451
9607fc9c 452 gv = gv_fetchmeth(stash, name, nend - name, 0);
a0d0e21e 453 if (!gv) {
2f6e0fe7 454 if (strEQ(name,"import") || strEQ(name,"unimport"))
3280af22 455 gv = (GV*)&PL_sv_yes;
dc848c6f 456 else if (autoload)
0dae17bd 457 gv = gv_autoload4(ostash, name, nend - name, TRUE);
463ee0b2 458 }
dc848c6f
PP
459 else if (autoload) {
460 CV* cv = GvCV(gv);
09280a33
CS
461 if (!CvROOT(cv) && !CvXSUB(cv)) {
462 GV* stubgv;
463 GV* autogv;
464
465 if (CvANON(cv))
466 stubgv = gv;
467 else {
468 stubgv = CvGV(cv);
469 if (GvCV(stubgv) != cv) /* orphaned import */
470 stubgv = gv;
471 }
472 autogv = gv_autoload4(GvSTASH(stubgv),
473 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
dc848c6f
PP
474 if (autogv)
475 gv = autogv;
476 }
477 }
44a8e56a
PP
478
479 return gv;
480}
481
482GV*
864dbfa3 483Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
44a8e56a 484{
df3728a2
JH
485 char autoload[] = "AUTOLOAD";
486 STRLEN autolen = sizeof(autoload)-1;
44a8e56a
PP
487 GV* gv;
488 CV* cv;
489 HV* varstash;
490 GV* vargv;
491 SV* varsv;
e1ec3a88 492 const char *packname = "";
44a8e56a
PP
493
494 if (len == autolen && strnEQ(name, autoload, autolen))
495 return Nullgv;
0dae17bd
GS
496 if (stash) {
497 if (SvTYPE(stash) < SVt_PVHV) {
498 packname = SvPV_nolen((SV*)stash);
499 stash = Nullhv;
500 }
501 else {
502 packname = HvNAME(stash);
503 }
504 }
dc848c6f
PP
505 if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
506 return Nullgv;
507 cv = GvCV(gv);
508
adb5a9ae 509 if (!(CvROOT(cv) || CvXSUB(cv)))
ed850460
JH
510 return Nullgv;
511
dc848c6f
PP
512 /*
513 * Inheriting AUTOLOAD for non-methods works ... for now.
514 */
12bcd1a6 515 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
599cee73 516 (GvCVGEN(gv) || GvSTASH(gv) != stash))
12bcd1a6 517 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
dc848c6f 518 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
0dae17bd 519 packname, (int)len, name);
44a8e56a 520
adb5a9ae
DM
521 if (CvXSUB(cv)) {
522 /* rather than lookup/init $AUTOLOAD here
523 * only to have the XSUB do another lookup for $AUTOLOAD
524 * and split that value on the last '::',
525 * pass along the same data via some unused fields in the CV
526 */
527 CvSTASH(cv) = stash;
f880fe2f 528 SvPV_set(cv, (char *)name); /* cast to lose constness warning */
b162af07 529 SvCUR_set(cv, len);
adb5a9ae
DM
530 return gv;
531 }
adb5a9ae 532
44a8e56a
PP
533 /*
534 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
535 * The subroutine's original name may not be "AUTOLOAD", so we don't
536 * use that, but for lack of anything better we will use the sub's
537 * original package to look up $AUTOLOAD.
538 */
539 varstash = GvSTASH(CvGV(cv));
540 vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
3d35f11b
GS
541 ENTER;
542
44a8e56a
PP
543 if (!isGV(vargv))
544 gv_init(vargv, varstash, autoload, autolen, FALSE);
3d35f11b 545 LEAVE;
44a8e56a 546 varsv = GvSV(vargv);
0dae17bd 547 sv_setpv(varsv, packname);
44a8e56a
PP
548 sv_catpvn(varsv, "::", 2);
549 sv_catpvn(varsv, name, len);
550 SvTAINTED_off(varsv);
a0d0e21e
LW
551 return gv;
552}
553
d2c93421
RH
554/* The "gv" parameter should be the glob known to Perl code as *!
555 * The scalar must already have been magicalized.
556 */
557STATIC void
558S_require_errno(pTHX_ GV *gv)
559{
560 HV* stash = gv_stashpvn("Errno",5,FALSE);
561
562 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
563 dSP;
564 PUTBACK;
565 ENTER;
566 save_scalar(gv); /* keep the value of $! */
84f1fa11
AMS
567 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
568 newSVpvn("Errno",5), Nullsv);
d2c93421
RH
569 LEAVE;
570 SPAGAIN;
571 stash = gv_stashpvn("Errno",5,FALSE);
572 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
573 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
574 }
575}
576
954c1994
GS
577/*
578=for apidoc gv_stashpv
579
386d01d6 580Returns a pointer to the stash for a specified package. C<name> should
bc96cb06
SH
581be a valid UTF-8 string and must be null-terminated. If C<create> is set
582then the package will be created if it does not already exist. If C<create>
583is not set and the package does not exist then NULL is returned.
954c1994
GS
584
585=cut
586*/
587
a0d0e21e 588HV*
864dbfa3 589Perl_gv_stashpv(pTHX_ const char *name, I32 create)
a0d0e21e 590{
dc437b57
PP
591 return gv_stashpvn(name, strlen(name), create);
592}
593
bc96cb06
SH
594/*
595=for apidoc gv_stashpvn
596
597Returns a pointer to the stash for a specified package. C<name> should
598be a valid UTF-8 string. The C<namelen> parameter indicates the length of
599the C<name>, in bytes. If C<create> is set then the package will be
600created if it does not already exist. If C<create> is not set and the
601package does not exist then NULL is returned.
602
603=cut
604*/
605
dc437b57 606HV*
864dbfa3 607Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
dc437b57 608{
46fc3d4c
PP
609 char smallbuf[256];
610 char *tmpbuf;
a0d0e21e
LW
611 HV *stash;
612 GV *tmpgv;
dc437b57 613
46fc3d4c
PP
614 if (namelen + 3 < sizeof smallbuf)
615 tmpbuf = smallbuf;
616 else
617 New(606, tmpbuf, namelen + 3, char);
dc437b57
PP
618 Copy(name,tmpbuf,namelen,char);
619 tmpbuf[namelen++] = ':';
620 tmpbuf[namelen++] = ':';
621 tmpbuf[namelen] = '\0';
46fc3d4c
PP
622 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
623 if (tmpbuf != smallbuf)
624 Safefree(tmpbuf);
a0d0e21e
LW
625 if (!tmpgv)
626 return 0;
627 if (!GvHV(tmpgv))
628 GvHV(tmpgv) = newHV();
629 stash = GvHV(tmpgv);
630 if (!HvNAME(stash))
631 HvNAME(stash) = savepv(name);
632 return stash;
463ee0b2
LW
633}
634
954c1994
GS
635/*
636=for apidoc gv_stashsv
637
386d01d6
GS
638Returns a pointer to the stash for a specified package, which must be a
639valid UTF-8 string. See C<gv_stashpv>.
954c1994
GS
640
641=cut
642*/
643
a0d0e21e 644HV*
864dbfa3 645Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
a0d0e21e 646{
dc437b57
PP
647 register char *ptr;
648 STRLEN len;
649 ptr = SvPV(sv,len);
650 return gv_stashpvn(ptr, len, create);
a0d0e21e
LW
651}
652
653
463ee0b2 654GV *
7a5fd60d
NC
655Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
656 STRLEN len = strlen (nambeg);
657 return gv_fetchpvn_flags(nambeg, len, add, sv_type);
658}
659
660GV *
661Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) {
662 STRLEN len;
663 const char *nambeg = SvPV(name, len);
664 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
665}
666
667GV *
668Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
669 I32 sv_type)
79072805 670{
08105a92 671 register const char *name = nambeg;
463ee0b2 672 register GV *gv = 0;
79072805 673 GV**gvp;
79072805 674 I32 len;
08105a92 675 register const char *namend;
463ee0b2 676 HV *stash = 0;
dd374669
AL
677 const I32 add = flags & ~SVf_UTF8;
678 (void)full_len;
79072805 679
c07a80fd
PP
680 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
681 name++;
682
79072805 683 for (namend = name; *namend; namend++) {
1d7c1841
GS
684 if ((*namend == ':' && namend[1] == ':')
685 || (*namend == '\'' && namend[1]))
463ee0b2 686 {
463ee0b2 687 if (!stash)
3280af22 688 stash = PL_defstash;
dc437b57 689 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
a0d0e21e 690 return Nullgv;
463ee0b2 691
85e6fe83
LW
692 len = namend - name;
693 if (len > 0) {
3c78fafa 694 char smallbuf[256];
62b57502 695 char *tmpbuf;
62b57502 696
25c09a70 697 if (len + 3 < sizeof (smallbuf))
3c78fafa 698 tmpbuf = smallbuf;
62b57502
MB
699 else
700 New(601, tmpbuf, len+3, char);
a0d0e21e
LW
701 Copy(name, tmpbuf, len, char);
702 tmpbuf[len++] = ':';
703 tmpbuf[len++] = ':';
704 tmpbuf[len] = '\0';
463ee0b2 705 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
6fa846a0 706 gv = gvp ? *gvp : Nullgv;
3280af22 707 if (gv && gv != (GV*)&PL_sv_undef) {
6fa846a0 708 if (SvTYPE(gv) != SVt_PVGV)
0f303493 709 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
6fa846a0
GS
710 else
711 GvMULTI_on(gv);
712 }
3c78fafa 713 if (tmpbuf != smallbuf)
62b57502 714 Safefree(tmpbuf);
3280af22 715 if (!gv || gv == (GV*)&PL_sv_undef)
a0d0e21e 716 return Nullgv;
85e6fe83 717
463ee0b2
LW
718 if (!(stash = GvHV(gv)))
719 stash = GvHV(gv) = newHV();
85e6fe83 720
463ee0b2 721 if (!HvNAME(stash))
a0d0e21e 722 HvNAME(stash) = savepvn(nambeg, namend - nambeg);
463ee0b2
LW
723 }
724
725 if (*namend == ':')
726 namend++;
727 namend++;
728 name = namend;
729 if (!*name)
3280af22 730 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
79072805 731 }
79072805 732 }
a0d0e21e 733 len = namend - name;
463ee0b2
LW
734
735 /* No stash in name, so see how we can default */
736
737 if (!stash) {
7e2040f0 738 if (isIDFIRST_lazy(name)) {
9607fc9c
PP
739 bool global = FALSE;
740
18ea00d7
NC
741 /* name is always \0 terminated, and initial \0 wouldn't return
742 true from isIDFIRST_lazy, so we know that name[1] is defined */
743 switch (name[1]) {
744 case '\0':
745 if (*name == '_')
9d116dd7 746 global = TRUE;
18ea00d7
NC
747 break;
748 case 'N':
749 if (strEQ(name, "INC") || strEQ(name, "ENV"))
9d116dd7 750 global = TRUE;
18ea00d7
NC
751 break;
752 case 'I':
753 if (strEQ(name, "SIG"))
9d116dd7 754 global = TRUE;
18ea00d7
NC
755 break;
756 case 'T':
757 if (strEQ(name, "STDIN") || strEQ(name, "STDOUT") ||
758 strEQ(name, "STDERR"))
463ee0b2 759 global = TRUE;
18ea00d7
NC
760 break;
761 case 'R':
762 if (strEQ(name, "ARGV") || strEQ(name, "ARGVOUT"))
763 global = TRUE;
764 break;
463ee0b2 765 }
9607fc9c 766
463ee0b2 767 if (global)
3280af22 768 stash = PL_defstash;
923e4eb5 769 else if (IN_PERL_COMPILETIME) {
3280af22
NIS
770 stash = PL_curstash;
771 if (add && (PL_hints & HINT_STRICT_VARS) &&
748a9306
LW
772 sv_type != SVt_PVCV &&
773 sv_type != SVt_PVGV &&
4633a7c4 774 sv_type != SVt_PVFM &&
c07a80fd 775 sv_type != SVt_PVIO &&
70ec6265
NC
776 !(len == 1 && sv_type == SVt_PV &&
777 (*name == 'a' || *name == 'b')) )
748a9306 778 {
4633a7c4
LW
779 gvp = (GV**)hv_fetch(stash,name,len,0);
780 if (!gvp ||
3280af22 781 *gvp == (GV*)&PL_sv_undef ||
a5f75d66
AD
782 SvTYPE(*gvp) != SVt_PVGV)
783 {
4633a7c4 784 stash = 0;
a5f75d66 785 }
155aba94
GS
786 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
787 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
788 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
4633a7c4 789 {
cea2e8a9 790 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
4633a7c4
LW
791 sv_type == SVt_PVAV ? '@' :
792 sv_type == SVt_PVHV ? '%' : '$',
793 name);
8ebc5c01 794 if (GvCVu(*gvp))
cc507455 795 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
a0d0e21e 796 stash = 0;
4633a7c4 797 }
a0d0e21e 798 }
85e6fe83 799 }
463ee0b2 800 else
1d7c1841 801 stash = CopSTASH(PL_curcop);
463ee0b2
LW
802 }
803 else
3280af22 804 stash = PL_defstash;
463ee0b2
LW
805 }
806
807 /* By this point we should have a stash and a name */
808
a0d0e21e 809 if (!stash) {
5a844595 810 if (add) {
608b3986 811 register SV *err = Perl_mess(aTHX_
5a844595
GS
812 "Global symbol \"%s%s\" requires explicit package name",
813 (sv_type == SVt_PV ? "$"
814 : sv_type == SVt_PVAV ? "@"
815 : sv_type == SVt_PVHV ? "%"
608b3986
AE
816 : ""), name);
817 if (USE_UTF8_IN_NAMES)
818 SvUTF8_on(err);
819 qerror(err);
d7aacf4e 820 stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
a0d0e21e 821 }
d7aacf4e
RGS
822 else
823 return Nullgv;
a0d0e21e
LW
824 }
825
826 if (!SvREFCNT(stash)) /* symbol table under destruction */
827 return Nullgv;
828
79072805 829 gvp = (GV**)hv_fetch(stash,name,len,add);
3280af22 830 if (!gvp || *gvp == (GV*)&PL_sv_undef)
79072805
LW
831 return Nullgv;
832 gv = *gvp;
833 if (SvTYPE(gv) == SVt_PVGV) {
a0d0e21e 834 if (add) {
a5f75d66 835 GvMULTI_on(gv);
a0d0e21e 836 gv_init_sv(gv, sv_type);
d2c93421
RH
837 if (*name=='!' && sv_type == SVt_PVHV && len==1)
838 require_errno(gv);
a0d0e21e 839 }
79072805 840 return gv;
55d729e4
GS
841 } else if (add & GV_NOINIT) {
842 return gv;
79072805 843 }
93a17b20
LW
844
845 /* Adding a new symbol */
846
0453d815 847 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
9014280d 848 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
55d729e4 849 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
a0d0e21e 850 gv_init_sv(gv, sv_type);
93a17b20 851
7272584d
PM
852 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
853 : (PL_dowarn & G_WARN_ON ) ) )
0453d815
PM
854 GvMULTI_on(gv) ;
855
93a17b20 856 /* set up magic where warranted */
cc4c2da6 857 if (len > 1) {
9431620d 858#ifndef EBCDIC
cc4c2da6
NC
859 if (*name > 'V' ) {
860 /* Nothing else to do.
91f565cb 861 The compiler will probably turn the switch statement into a
cc4c2da6
NC
862 branch table. Make sure we avoid even that small overhead for
863 the common case of lower case variable names. */
9431620d
NC
864 } else
865#endif
866 {
cc4c2da6
NC
867 const char *name2 = name + 1;
868 switch (*name) {
869 case 'A':
870 if (strEQ(name2, "RGV")) {
871 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
872 }
873 break;
874 case 'E':
875 if (strnEQ(name2, "XPORT", 5))
876 GvMULTI_on(gv);
877 break;
878 case 'I':
879 if (strEQ(name2, "SA")) {
880 AV* av = GvAVn(gv);
881 GvMULTI_on(gv);
882 sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
883 /* NOTE: No support for tied ISA */
884 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
885 && AvFILLp(av) == -1)
886 {
e1ec3a88 887 const char *pname;
cc4c2da6
NC
888 av_push(av, newSVpvn(pname = "NDBM_File",9));
889 gv_stashpvn(pname, 9, TRUE);
890 av_push(av, newSVpvn(pname = "DB_File",7));
891 gv_stashpvn(pname, 7, TRUE);
892 av_push(av, newSVpvn(pname = "GDBM_File",9));
893 gv_stashpvn(pname, 9, TRUE);
894 av_push(av, newSVpvn(pname = "SDBM_File",9));
895 gv_stashpvn(pname, 9, TRUE);
896 av_push(av, newSVpvn(pname = "ODBM_File",9));
897 gv_stashpvn(pname, 9, TRUE);
898 }
899 }
900 break;
901 case 'O':
902 if (strEQ(name2, "VERLOAD")) {
903 HV* hv = GvHVn(gv);
904 GvMULTI_on(gv);
905 hv_magic(hv, Nullgv, PERL_MAGIC_overload);
906 }
907 break;
908 case 'S':
909 if (strEQ(name2, "IG")) {
910 HV *hv;
911 I32 i;
912 if (!PL_psig_ptr) {
913 Newz(73, PL_psig_ptr, SIG_SIZE, SV*);
914 Newz(73, PL_psig_name, SIG_SIZE, SV*);
915 Newz(73, PL_psig_pend, SIG_SIZE, int);
916 }
917 GvMULTI_on(gv);
918 hv = GvHVn(gv);
919 hv_magic(hv, Nullgv, PERL_MAGIC_sig);
920 for (i = 1; i < SIG_SIZE; i++) {
921 SV ** init;
922 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
923 if (init)
924 sv_setsv(*init, &PL_sv_undef);
925 PL_psig_ptr[i] = 0;
926 PL_psig_name[i] = 0;
927 PL_psig_pend[i] = 0;
928 }
929 }
930 break;
931 case 'V':
932 if (strEQ(name2, "ERSION"))
933 GvMULTI_on(gv);
934 break;
935 case '\005': /* $^ENCODING */
936 if (strEQ(name2, "NCODING"))
937 goto magicalize;
938 break;
939 case '\017': /* $^OPEN */
940 if (strEQ(name2, "PEN"))
941 goto magicalize;
942 break;
943 case '\024': /* ${^TAINT} */
944 if (strEQ(name2, "AINT"))
945 goto ro_magicalize;
946 break;
7cebcbc0 947 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
cc4c2da6
NC
948 if (strEQ(name2, "NICODE"))
949 goto ro_magicalize;
7cebcbc0
NC
950 if (strEQ(name2, "TF8LOCALE"))
951 goto ro_magicalize;
cc4c2da6
NC
952 break;
953 case '\027': /* $^WARNING_BITS */
954 if (strEQ(name2, "ARNING_BITS"))
955 goto magicalize;
956 break;
957 case '1':
958 case '2':
959 case '3':
960 case '4':
961 case '5':
962 case '6':
963 case '7':
964 case '8':
965 case '9':
85e6fe83 966 {
cc4c2da6
NC
967 /* ensures variable is only digits */
968 /* ${"1foo"} fails this test (and is thus writeable) */
969 /* added by japhy, but borrowed from is_gv_magical */
970 const char *end = name + len;
971 while (--end > name) {
972 if (!isDIGIT(*end)) return gv;
973 }
974 goto ro_magicalize;
1d7c1841 975 }
dc437b57 976 }
93a17b20 977 }
392db708
NC
978 } else {
979 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
980 be case '\0' in this switch statement (ie a default case) */
cc4c2da6
NC
981 switch (*name) {
982 case '&':
983 case '`':
984 case '\'':
985 if (
986 sv_type == SVt_PVAV ||
987 sv_type == SVt_PVHV ||
988 sv_type == SVt_PVCV ||
989 sv_type == SVt_PVFM ||
990 sv_type == SVt_PVIO
991 ) { break; }
992 PL_sawampersand = TRUE;
993 goto ro_magicalize;
994
995 case ':':
996 sv_setpv(GvSV(gv),PL_chopset);
997 goto magicalize;
998
999 case '?':
ff0cee69 1000#ifdef COMPLEX_STATUS
cc4c2da6 1001 (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
ff0cee69 1002#endif
cc4c2da6 1003 goto magicalize;
ff0cee69 1004
cc4c2da6 1005 case '!':
d2c93421 1006
cc4c2da6
NC
1007 /* If %! has been used, automatically load Errno.pm.
1008 The require will itself set errno, so in order to
1009 preserve its value we have to set up the magic
1010 now (rather than going to magicalize)
1011 */
d2c93421 1012
cc4c2da6 1013 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
d2c93421 1014
cc4c2da6
NC
1015 if (sv_type == SVt_PVHV)
1016 require_errno(gv);
d2c93421 1017
6cef1e77 1018 break;
cc4c2da6
NC
1019 case '-':
1020 {
6cef1e77 1021 AV* av = GvAVn(gv);
14befaf4 1022 sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
03a27ae7 1023 SvREADONLY_on(av);
cc4c2da6
NC
1024 goto magicalize;
1025 }
1026 case '*':
1027 if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1028 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1029 "$* is no longer supported");
6cef1e77 1030 break;
cc4c2da6
NC
1031 case '#':
1032 if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1033 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1034 "Use of $# is deprecated");
1035 goto magicalize;
1036 case '|':
1037 sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1038 goto magicalize;
1039
1040 case '+':
1041 {
1042 AV* av = GvAVn(gv);
14befaf4 1043 sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
03a27ae7 1044 SvREADONLY_on(av);
cc4c2da6 1045 /* FALL THROUGH */
e521374c 1046 }
cc4c2da6
NC
1047 case '\023': /* $^S */
1048 case '1':
1049 case '2':
1050 case '3':
1051 case '4':
1052 case '5':
1053 case '6':
1054 case '7':
1055 case '8':
1056 case '9':
1057 ro_magicalize:
1058 SvREADONLY_on(GvSV(gv));
1059 /* FALL THROUGH */
1060 case '[':
1061 case '^':
1062 case '~':
1063 case '=':
1064 case '%':
1065 case '.':
1066 case '(':
1067 case ')':
1068 case '<':
1069 case '>':
1070 case ',':
1071 case '\\':
1072 case '/':
1073 case '\001': /* $^A */
1074 case '\003': /* $^C */
1075 case '\004': /* $^D */
1076 case '\005': /* $^E */
1077 case '\006': /* $^F */
1078 case '\010': /* $^H */
1079 case '\011': /* $^I, NOT \t in EBCDIC */
1080 case '\016': /* $^N */
1081 case '\017': /* $^O */
1082 case '\020': /* $^P */
1083 case '\024': /* $^T */
1084 case '\027': /* $^W */
1085 magicalize:
1086 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1087 break;
e521374c 1088
cc4c2da6
NC
1089 case '\014': /* $^L */
1090 sv_setpv(GvSV(gv),"\f");
1091 PL_formfeed = GvSV(gv);
463ee0b2 1092 break;
cc4c2da6
NC
1093 case ';':
1094 sv_setpv(GvSV(gv),"\034");
463ee0b2 1095 break;
cc4c2da6
NC
1096 case ']':
1097 {
f86702cc 1098 SV *sv = GvSV(gv);
d7aa5382
JP
1099 if (!sv_derived_from(PL_patchlevel, "version"))
1100 (void *)upg_version(PL_patchlevel);
7d54d38e
SH
1101 GvSV(gv) = vnumify(PL_patchlevel);
1102 SvREADONLY_on(GvSV(gv));
1103 SvREFCNT_dec(sv);
93a17b20
LW
1104 }
1105 break;
cc4c2da6
NC
1106 case '\026': /* $^V */
1107 {
35a4481c 1108 SV * const sv = GvSV(gv);
f9be5ac8
DM
1109 GvSV(gv) = new_version(PL_patchlevel);
1110 SvREADONLY_on(GvSV(gv));
1111 SvREFCNT_dec(sv);
16070b82
GS
1112 }
1113 break;
cc4c2da6 1114 }
79072805 1115 }
93a17b20 1116 return gv;
79072805
LW
1117}
1118
1119void
35a4481c 1120Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
43693395 1121{
35a4481c
AL
1122 const char *name;
1123 const HV * const hv = GvSTASH(gv);
43693395 1124 if (!hv) {
0c34ef67 1125 SvOK_off(sv);
43693395
GS
1126 return;
1127 }
1128 sv_setpv(sv, prefix ? prefix : "");
e27ad1f2 1129
9dde0ab5
NC
1130 name = HvNAME(hv);
1131 if (!name)
e27ad1f2 1132 name = "__ANON__";
9dde0ab5 1133
e27ad1f2 1134 if (keepmain || strNE(name, "main")) {
6a7a3232
NC
1135 sv_catpv(sv,name);
1136 sv_catpvn(sv,"::", 2);
43693395 1137 }
257984c0 1138 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
43693395
GS
1139}
1140
1141void
35a4481c 1142Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
79072805 1143{
84e79d79 1144 gv_fullname4(sv, gv, prefix, TRUE);
79072805
LW
1145}
1146
1147void
35a4481c 1148Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
43693395 1149{
35a4481c 1150 const GV *egv = GvEGV(gv);
43693395
GS
1151 if (!egv)
1152 egv = gv;
1153 gv_fullname4(sv, egv, prefix, keepmain);
1154}
1155
1156void
35a4481c 1157Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
79072805 1158{
84e79d79 1159 gv_efullname4(sv, gv, prefix, TRUE);
f6aff53a
PP
1160}
1161
35a4481c 1162/* compatibility with versions <= 5.003. */
f6aff53a 1163void
35a4481c 1164Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
f6aff53a 1165{
35a4481c 1166 gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
f6aff53a
PP
1167}
1168
35a4481c 1169/* compatibility with versions <= 5.003. */
f6aff53a 1170void
35a4481c 1171Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
f6aff53a 1172{
e1ec3a88 1173 gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
79072805
LW
1174}
1175
1176IO *
864dbfa3 1177Perl_newIO(pTHX)
79072805
LW
1178{
1179 IO *io;
8990e307
LW
1180 GV *iogv;
1181
1182 io = (IO*)NEWSV(0,0);
a0d0e21e 1183 sv_upgrade((SV *)io,SVt_PVIO);
8990e307
LW
1184 SvREFCNT(io) = 1;
1185 SvOBJECT_on(io);
081fc587
AB
1186 /* Clear the stashcache because a new IO could overrule a
1187 package name */
1188 hv_clear(PL_stashcache);
c9de509e 1189 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
5f2d631d
GS
1190 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1191 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
c9de509e 1192 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
b162af07 1193 SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
79072805
LW
1194 return io;
1195}
1196
1197void
864dbfa3 1198Perl_gv_check(pTHX_ HV *stash)
79072805 1199{
79072805
LW
1200 register I32 i;
1201 register GV *gv;
463ee0b2
LW
1202 HV *hv;
1203
8990e307
LW
1204 if (!HvARRAY(stash))
1205 return;
a0d0e21e 1206 for (i = 0; i <= (I32) HvMAX(stash); i++) {
e1ec3a88 1207 const HE *entry;
dc437b57
PP
1208 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1209 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
b862623f 1210 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
a0d0e21e 1211 {
19b6c847 1212 if (hv != PL_defstash && hv != stash)
a0d0e21e
LW
1213 gv_check(hv); /* nested package */
1214 }
dc437b57 1215 else if (isALPHA(*HeKEY(entry))) {
e1ec3a88 1216 const char *file;
dc437b57 1217 gv = (GV*)HeVAL(entry);
55d729e4 1218 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
463ee0b2 1219 continue;
1d7c1841
GS
1220 file = GvFILE(gv);
1221 /* performance hack: if filename is absolute and it's a standard
1222 * module, don't bother warning */
1223 if (file
1224 && PERL_FILE_IS_ABSOLUTE(file)
6eb630b7
CN
1225#ifdef MACOS_TRADITIONAL
1226 && (instr(file, ":lib:")
1227#else
1228 && (instr(file, "/lib/")
1229#endif
1230 || instr(file, ".pm")))
1d7c1841 1231 {
8990e307 1232 continue;
1d7c1841
GS
1233 }
1234 CopLINE_set(PL_curcop, GvLINE(gv));
1235#ifdef USE_ITHREADS
dd374669 1236 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1d7c1841
GS
1237#else
1238 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1239#endif
9014280d 1240 Perl_warner(aTHX_ packWARN(WARN_ONCE),
599cee73 1241 "Name \"%s::%s\" used only once: possible typo",
a0d0e21e 1242 HvNAME(stash), GvNAME(gv));
463ee0b2 1243 }
79072805
LW
1244 }
1245 }
1246}
1247
1248GV *
e1ec3a88 1249Perl_newGVgen(pTHX_ const char *pack)
79072805 1250{
cea2e8a9 1251 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
46fc3d4c 1252 TRUE, SVt_PVGV);
79072805
LW
1253}
1254
1255/* hopefully this is only called on local symbol table entries */
1256
1257GP*
864dbfa3 1258Perl_gp_ref(pTHX_ GP *gp)
79072805 1259{
1d7c1841
GS
1260 if (!gp)
1261 return (GP*)NULL;
79072805 1262 gp->gp_refcnt++;
44a8e56a
PP
1263 if (gp->gp_cv) {
1264 if (gp->gp_cvgen) {
1265 /* multi-named GPs cannot be used for method cache */
1266 SvREFCNT_dec(gp->gp_cv);
1267 gp->gp_cv = Nullcv;
1268 gp->gp_cvgen = 0;
1269 }
1270 else {
1271 /* Adding a new name to a subroutine invalidates method cache */
3280af22 1272 PL_sub_generation++;
44a8e56a
PP
1273 }
1274 }
79072805 1275 return gp;
79072805
LW
1276}
1277
1278void
864dbfa3 1279Perl_gp_free(pTHX_ GV *gv)
79072805 1280{
79072805
LW
1281 GP* gp;
1282
1283 if (!gv || !(gp = GvGP(gv)))
1284 return;
f248d071
GS
1285 if (gp->gp_refcnt == 0) {
1286 if (ckWARN_d(WARN_INTERNAL))
9014280d 1287 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
472d47bc
SB
1288 "Attempt to free unreferenced glob pointers"
1289 pTHX__FORMAT pTHX__VALUE);
79072805
LW
1290 return;
1291 }
44a8e56a
PP
1292 if (gp->gp_cv) {
1293 /* Deleting the name of a subroutine invalidates method cache */
3280af22 1294 PL_sub_generation++;
44a8e56a 1295 }
748a9306
LW
1296 if (--gp->gp_refcnt > 0) {
1297 if (gp->gp_egv == gv)
1298 gp->gp_egv = 0;
79072805 1299 return;
748a9306 1300 }
79072805 1301
13207a71 1302 if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
8926f269 1303 if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
13207a71
JH
1304 if (gp->gp_hv) {
1305 if (PL_stashcache && HvNAME(gp->gp_hv))
1306 hv_delete(PL_stashcache,
1307 HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)),
1308 G_DISCARD);
1309 SvREFCNT_dec(gp->gp_hv);
1310 }
1311 if (gp->gp_io) SvREFCNT_dec(gp->gp_io);
1312 if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv);
1313 if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
748a9306 1314
79072805
LW
1315 Safefree(gp);
1316 GvGP(gv) = 0;
1317}
1318
d460ef45
NIS
1319int
1320Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1321{
1322 AMT *amtp = (AMT*)mg->mg_ptr;
dd374669
AL
1323 (void)sv;
1324
d460ef45
NIS
1325 if (amtp && AMT_AMAGIC(amtp)) {
1326 int i;
1327 for (i = 1; i < NofAMmeth; i++) {
1328 CV *cv = amtp->table[i];
1329 if (cv != Nullcv) {
1330 SvREFCNT_dec((SV *) cv);
1331 amtp->table[i] = Nullcv;
1332 }
1333 }
1334 }
1335 return 0;
1336}
1337
a0d0e21e
LW
1338/* Updates and caches the CV's */
1339
1340bool
864dbfa3 1341Perl_Gv_AMupdate(pTHX_ HV *stash)
a0d0e21e 1342{
a0d0e21e
LW
1343 GV* gv;
1344 CV* cv;
14befaf4 1345 MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
8ac85365 1346 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
a6006777 1347 AMT amt;
a0d0e21e 1348
3280af22
NIS
1349 if (mg && amtp->was_ok_am == PL_amagic_generation
1350 && amtp->was_ok_sub == PL_sub_generation)
eb160463 1351 return (bool)AMT_OVERLOADED(amtp);
14befaf4 1352 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
a0d0e21e 1353
cea2e8a9 1354 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
a0d0e21e 1355
d460ef45 1356 Zero(&amt,1,AMT);
3280af22
NIS
1357 amt.was_ok_am = PL_amagic_generation;
1358 amt.was_ok_sub = PL_sub_generation;
a6006777
PP
1359 amt.fallback = AMGfallNO;
1360 amt.flags = 0;
1361
a6006777 1362 {
32251b26
IZ
1363 int filled = 0, have_ovl = 0;
1364 int i, lim = 1;
a6006777 1365 SV* sv = NULL;
a6006777 1366
22c35a8c 1367 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
a6006777 1368
89ffc314
IZ
1369 /* Try to find via inheritance. */
1370 gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1371 if (gv)
1372 sv = GvSV(gv);
1373
1374 if (!gv)
32251b26 1375 lim = DESTROY_amg; /* Skip overloading entries. */
89ffc314
IZ
1376 else if (SvTRUE(sv))
1377 amt.fallback=AMGfallYES;
1378 else if (SvOK(sv))
1379 amt.fallback=AMGfallNEVER;
a6006777 1380
32251b26
IZ
1381 for (i = 1; i < lim; i++)
1382 amt.table[i] = Nullcv;
1383 for (; i < NofAMmeth; i++) {
e1ec3a88 1384 const char *cooky = PL_AMG_names[i];
32251b26 1385 /* Human-readable form, for debugging: */
e1ec3a88
AL
1386 const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1387 const STRLEN l = strlen(cooky);
89ffc314 1388
cea2e8a9 1389 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
44a8e56a 1390 cp, HvNAME(stash)) );
611c1e95
IZ
1391 /* don't fill the cache while looking up!
1392 Creation of inheritance stubs in intermediate packages may
1393 conflict with the logic of runtime method substitution.
1394 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1395 then we could have created stubs for "(+0" in A and C too.
1396 But if B overloads "bool", we may want to use it for
1397 numifying instead of C's "+0". */
1398 if (i >= DESTROY_amg)
1399 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1400 else /* Autoload taken care of below */
1401 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
46fc3d4c 1402 cv = 0;
89ffc314 1403 if (gv && (cv = GvCV(gv))) {
44a8e56a
PP
1404 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1405 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
611c1e95
IZ
1406 /* This is a hack to support autoloading..., while
1407 knowing *which* methods were declared as overloaded. */
44a8e56a 1408 /* GvSV contains the name of the method. */
4ea42e7f 1409 GV *ngv = Nullgv;
44a8e56a 1410
84c133a0
RB
1411 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%"SVf256\
1412 "' for overloaded `%s' in package `%.256s'\n",
35c1215d 1413 GvSV(gv), cp, HvNAME(stash)) );
b267980d 1414 if (!SvPOK(GvSV(gv))
dc848c6f
PP
1415 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1416 FALSE)))
1417 {
44a8e56a 1418 /* Can be an import stub (created by `can'). */
35c1215d
NC
1419 SV *gvsv = GvSV(gv);
1420 const char *name = SvPOK(gvsv) ? SvPVX(gvsv) : "???";
84c133a0
RB
1421 Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' "\
1422 "in package `%.256s'",
35c1215d
NC
1423 (GvCVGEN(gv) ? "Stub found while resolving"
1424 : "Can't resolve"),
1425 name, cp, HvNAME(stash));
44a8e56a 1426 }
dc848c6f 1427 cv = GvCV(gv = ngv);
44a8e56a 1428 }
cea2e8a9 1429 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
44a8e56a
PP
1430 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1431 GvNAME(CvGV(cv))) );
1432 filled = 1;
32251b26
IZ
1433 if (i < DESTROY_amg)
1434 have_ovl = 1;
611c1e95
IZ
1435 } else if (gv) { /* Autoloaded... */
1436 cv = (CV*)gv;
1437 filled = 1;
44a8e56a 1438 }
a6006777 1439 amt.table[i]=(CV*)SvREFCNT_inc(cv);
a0d0e21e 1440 }
a0d0e21e 1441 if (filled) {
a6006777 1442 AMT_AMAGIC_on(&amt);
32251b26
IZ
1443 if (have_ovl)
1444 AMT_OVERLOADED_on(&amt);
14befaf4
DM
1445 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1446 (char*)&amt, sizeof(AMT));
32251b26 1447 return have_ovl;
a0d0e21e
LW
1448 }
1449 }
a6006777 1450 /* Here we have no table: */
9cbac4c7 1451 /* no_table: */
a6006777 1452 AMT_AMAGIC_off(&amt);
14befaf4
DM
1453 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1454 (char*)&amt, sizeof(AMTS));
a0d0e21e
LW
1455 return FALSE;
1456}
1457
32251b26
IZ
1458
1459CV*
1460Perl_gv_handler(pTHX_ HV *stash, I32 id)
1461{
3f8f4626 1462 MAGIC *mg;
32251b26 1463 AMT *amtp;
3ad83ce7 1464 CV *ret;
32251b26 1465
e27ad1f2 1466 if (!stash || !HvNAME(stash))
3f8f4626 1467 return Nullcv;
14befaf4 1468 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
32251b26
IZ
1469 if (!mg) {
1470 do_update:
1471 Gv_AMupdate(stash);
14befaf4 1472 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
32251b26
IZ
1473 }
1474 amtp = (AMT*)mg->mg_ptr;
1475 if ( amtp->was_ok_am != PL_amagic_generation
1476 || amtp->was_ok_sub != PL_sub_generation )
1477 goto do_update;
3ad83ce7
AMS
1478 if (AMT_AMAGIC(amtp)) {
1479 ret = amtp->table[id];
1480 if (ret && isGV(ret)) { /* Autoloading stab */
1481 /* Passing it through may have resulted in a warning
1482 "Inherited AUTOLOAD for a non-method deprecated", since
1483 our caller is going through a function call, not a method call.
1484 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
e1ec3a88 1485 GV *gv = gv_fetchmethod(stash, PL_AMG_names[id]);
3ad83ce7
AMS
1486
1487 if (gv && GvCV(gv))
1488 return GvCV(gv);
1489 }
1490 return ret;
1491 }
1492
32251b26
IZ
1493 return Nullcv;
1494}
1495
1496
a0d0e21e 1497SV*
864dbfa3 1498Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
a0d0e21e 1499{
b267980d 1500 MAGIC *mg;
9c5ffd7c 1501 CV *cv=NULL;
a0d0e21e 1502 CV **cvp=NULL, **ocvp=NULL;
9c5ffd7c 1503 AMT *amtp=NULL, *oamtp=NULL;
497b47a8 1504 int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
ee239bfe 1505 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
497b47a8
JH
1506#ifdef DEBUGGING
1507 int fl=0;
497b47a8 1508#endif
25716404 1509 HV* stash=NULL;
a0d0e21e 1510 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
25716404
GS
1511 && (stash = SvSTASH(SvRV(left)))
1512 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
b267980d 1513 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 1514 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
8ac85365 1515 : (CV **) NULL))
b267980d 1516 && ((cv = cvp[off=method+assignshift])
748a9306
LW
1517 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1518 * usual method */
497b47a8
JH
1519 (
1520#ifdef DEBUGGING
1521 fl = 1,
1522#endif
1523 cv = cvp[off=method])))) {
a0d0e21e
LW
1524 lr = -1; /* Call method for left argument */
1525 } else {
1526 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1527 int logic;
1528
1529 /* look for substituted methods */
ee239bfe 1530 /* In all the covered cases we should be called with assign==0. */
a0d0e21e
LW
1531 switch (method) {
1532 case inc_amg:
ee239bfe
IZ
1533 force_cpy = 1;
1534 if ((cv = cvp[off=add_ass_amg])
1535 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3280af22 1536 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1537 }
1538 break;
1539 case dec_amg:
ee239bfe
IZ
1540 force_cpy = 1;
1541 if ((cv = cvp[off = subtr_ass_amg])
1542 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3280af22 1543 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1544 }
1545 break;
1546 case bool__amg:
1547 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1548 break;
1549 case numer_amg:
1550 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1551 break;
1552 case string_amg:
1553 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1554 break;
dc437b57 1555 case not_amg:
b267980d 1556 (void)((cv = cvp[off=bool__amg])
dc437b57
PP
1557 || (cv = cvp[off=numer_amg])
1558 || (cv = cvp[off=string_amg]));
1559 postpr = 1;
1560 break;
748a9306
LW
1561 case copy_amg:
1562 {
76e3520e
GS
1563 /*
1564 * SV* ref causes confusion with the interpreter variable of
1565 * the same name
1566 */
1567 SV* tmpRef=SvRV(left);
1568 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
fc36a67e
PP
1569 /*
1570 * Just to be extra cautious. Maybe in some
1571 * additional cases sv_setsv is safe, too.
1572 */
76e3520e 1573 SV* newref = newSVsv(tmpRef);
748a9306 1574 SvOBJECT_on(newref);
b162af07 1575 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
748a9306
LW
1576 return newref;
1577 }
1578 }
1579 break;
a0d0e21e 1580 case abs_amg:
b267980d 1581 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
a0d0e21e 1582 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
748a9306 1583 SV* nullsv=sv_2mortal(newSViv(0));
a0d0e21e 1584 if (off1==lt_amg) {
748a9306 1585 SV* lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1586 lt_amg,AMGf_noright);
1587 logic = SvTRUE(lessp);
1588 } else {
748a9306 1589 SV* lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1590 ncmp_amg,AMGf_noright);
1591 logic = (SvNV(lessp) < 0);
1592 }
1593 if (logic) {
1594 if (off==subtr_amg) {
1595 right = left;
748a9306 1596 left = nullsv;
a0d0e21e
LW
1597 lr = 1;
1598 }
1599 } else {
1600 return left;
1601 }
1602 }
1603 break;
1604 case neg_amg:
155aba94 1605 if ((cv = cvp[off=subtr_amg])) {
a0d0e21e
LW
1606 right = left;
1607 left = sv_2mortal(newSViv(0));
1608 lr = 1;
1609 }
1610 break;
f216259d 1611 case int_amg:
f5284f61 1612 case iter_amg: /* XXXX Eventually should do to_gv. */
b267980d
NIS
1613 /* FAIL safe */
1614 return NULL; /* Delegate operation to standard mechanisms. */
1615 break;
f5284f61
IZ
1616 case to_sv_amg:
1617 case to_av_amg:
1618 case to_hv_amg:
1619 case to_gv_amg:
1620 case to_cv_amg:
1621 /* FAIL safe */
b267980d 1622 return left; /* Delegate operation to standard mechanisms. */
f5284f61 1623 break;
a0d0e21e
LW
1624 default:
1625 goto not_found;
1626 }
1627 if (!cv) goto not_found;
1628 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
25716404
GS
1629 && (stash = SvSTASH(SvRV(right)))
1630 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
b267980d 1631 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 1632 ? (amtp = (AMT*)mg->mg_ptr)->table
8ac85365 1633 : (CV **) NULL))
a0d0e21e
LW
1634 && (cv = cvp[off=method])) { /* Method for right
1635 * argument found */
1636 lr=1;
b267980d
NIS
1637 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1638 && (cvp=ocvp) && (lr = -1))
a0d0e21e
LW
1639 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1640 && !(flags & AMGf_unary)) {
1641 /* We look for substitution for
1642 * comparison operations and
fc36a67e 1643 * concatenation */
a0d0e21e
LW
1644 if (method==concat_amg || method==concat_ass_amg
1645 || method==repeat_amg || method==repeat_ass_amg) {
1646 return NULL; /* Delegate operation to string conversion */
1647 }
1648 off = -1;
1649 switch (method) {
1650 case lt_amg:
1651 case le_amg:
1652 case gt_amg:
1653 case ge_amg:
1654 case eq_amg:
1655 case ne_amg:
1656 postpr = 1; off=ncmp_amg; break;
1657 case slt_amg:
1658 case sle_amg:
1659 case sgt_amg:
1660 case sge_amg:
1661 case seq_amg:
1662 case sne_amg:
1663 postpr = 1; off=scmp_amg; break;
1664 }
1665 if (off != -1) cv = cvp[off];
1666 if (!cv) {
1667 goto not_found;
1668 }
1669 } else {
a6006777 1670 not_found: /* No method found, either report or croak */
b267980d
NIS
1671 switch (method) {
1672 case to_sv_amg:
1673 case to_av_amg:
1674 case to_hv_amg:
1675 case to_gv_amg:
1676 case to_cv_amg:
1677 /* FAIL safe */
1678 return left; /* Delegate operation to standard mechanisms. */
1679 break;
1680 }
a0d0e21e
LW
1681 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1682 notfound = 1; lr = -1;
1683 } else if (cvp && (cv=cvp[nomethod_amg])) {
1684 notfound = 1; lr = 1;
1685 } else {
46fc3d4c 1686 SV *msg;
774d564b 1687 if (off==-1) off=method;
b267980d 1688 msg = sv_2mortal(Perl_newSVpvf(aTHX_
46fc3d4c 1689 "Operation `%s': no method found,%sargument %s%s%s%s",
89ffc314 1690 AMG_id2name(method + assignshift),
e7ea3e70 1691 (flags & AMGf_unary ? " " : "\n\tleft "),
b267980d 1692 SvAMAGIC(left)?
a0d0e21e
LW
1693 "in overloaded package ":
1694 "has no overloaded magic",
b267980d 1695 SvAMAGIC(left)?
a0d0e21e
LW
1696 HvNAME(SvSTASH(SvRV(left))):
1697 "",
b267980d 1698 SvAMAGIC(right)?
e7ea3e70 1699 ",\n\tright argument in overloaded package ":
b267980d 1700 (flags & AMGf_unary
e7ea3e70
IZ
1701 ? ""
1702 : ",\n\tright argument has no overloaded magic"),
b267980d 1703 SvAMAGIC(right)?
a0d0e21e 1704 HvNAME(SvSTASH(SvRV(right))):
46fc3d4c 1705 ""));
a0d0e21e 1706 if (amtp && amtp->fallback >= AMGfallYES) {
cea2e8a9 1707 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
a0d0e21e 1708 } else {
894356b3 1709 Perl_croak(aTHX_ "%"SVf, msg);
a0d0e21e
LW
1710 }
1711 return NULL;
1712 }
ee239bfe 1713 force_cpy = force_cpy || assign;
a0d0e21e
LW
1714 }
1715 }
497b47a8 1716#ifdef DEBUGGING
a0d0e21e 1717 if (!notfound) {
497b47a8
JH
1718 DEBUG_o(Perl_deb(aTHX_
1719 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1720 AMG_id2name(off),
1721 method+assignshift==off? "" :
1722 " (initially `",
1723 method+assignshift==off? "" :
1724 AMG_id2name(method+assignshift),
1725 method+assignshift==off? "" : "')",
1726 flags & AMGf_unary? "" :
1727 lr==1 ? " for right argument": " for left argument",
1728 flags & AMGf_unary? " for argument" : "",
25716404 1729 stash ? HvNAME(stash) : "null",
497b47a8 1730 fl? ",\n\tassignment variant used": "") );
ee239bfe 1731 }
497b47a8 1732#endif
748a9306
LW
1733 /* Since we use shallow copy during assignment, we need
1734 * to dublicate the contents, probably calling user-supplied
1735 * version of copy operator
1736 */
ee239bfe
IZ
1737 /* We need to copy in following cases:
1738 * a) Assignment form was called.
1739 * assignshift==1, assign==T, method + 1 == off
1740 * b) Increment or decrement, called directly.
1741 * assignshift==0, assign==0, method + 0 == off
1742 * c) Increment or decrement, translated to assignment add/subtr.
b267980d 1743 * assignshift==0, assign==T,
ee239bfe
IZ
1744 * force_cpy == T
1745 * d) Increment or decrement, translated to nomethod.
b267980d 1746 * assignshift==0, assign==0,
ee239bfe
IZ
1747 * force_cpy == T
1748 * e) Assignment form translated to nomethod.
1749 * assignshift==1, assign==T, method + 1 != off
1750 * force_cpy == T
1751 */
1752 /* off is method, method+assignshift, or a result of opcode substitution.
1753 * In the latter case assignshift==0, so only notfound case is important.
1754 */
1755 if (( (method + assignshift == off)
1756 && (assign || (method == inc_amg) || (method == dec_amg)))
1757 || force_cpy)
1758 RvDEEPCP(left);
a0d0e21e
LW
1759 {
1760 dSP;
1761 BINOP myop;
1762 SV* res;
54310121 1763 bool oldcatch = CATCH_GET;
a0d0e21e 1764
54310121 1765 CATCH_SET(TRUE);
a0d0e21e
LW
1766 Zero(&myop, 1, BINOP);
1767 myop.op_last = (OP *) &myop;
1768 myop.op_next = Nullop;
54310121 1769 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
a0d0e21e 1770
e788e7d3 1771 PUSHSTACKi(PERLSI_OVERLOAD);
a0d0e21e 1772 ENTER;
462e5cf6 1773 SAVEOP();
533c011a 1774 PL_op = (OP *) &myop;
3280af22 1775 if (PERLDB_SUB && PL_curstash != PL_debstash)
533c011a 1776 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 1777 PUTBACK;
cea2e8a9 1778 pp_pushmark();
a0d0e21e 1779
924508f0 1780 EXTEND(SP, notfound + 5);
a0d0e21e
LW
1781 PUSHs(lr>0? right: left);
1782 PUSHs(lr>0? left: right);
3280af22 1783 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
a0d0e21e 1784 if (notfound) {
89ffc314 1785 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
a0d0e21e
LW
1786 }
1787 PUSHs((SV*)cv);
1788 PUTBACK;
1789
155aba94 1790 if ((PL_op = Perl_pp_entersub(aTHX)))
cea2e8a9 1791 CALLRUNOPS(aTHX);
a0d0e21e
LW
1792 LEAVE;
1793 SPAGAIN;
1794
1795 res=POPs;
ebafeae7 1796 PUTBACK;
d3acc0f7 1797 POPSTACK;
54310121 1798 CATCH_SET(oldcatch);
a0d0e21e 1799
a0d0e21e 1800 if (postpr) {
9c5ffd7c 1801 int ans=0;
a0d0e21e
LW
1802 switch (method) {
1803 case le_amg:
1804 case sle_amg:
1805 ans=SvIV(res)<=0; break;
1806 case lt_amg:
1807 case slt_amg:
1808 ans=SvIV(res)<0; break;
1809 case ge_amg:
1810 case sge_amg:
1811 ans=SvIV(res)>=0; break;
1812 case gt_amg:
1813 case sgt_amg:
1814 ans=SvIV(res)>0; break;
1815 case eq_amg:
1816 case seq_amg:
1817 ans=SvIV(res)==0; break;
1818 case ne_amg:
1819 case sne_amg:
1820 ans=SvIV(res)!=0; break;
1821 case inc_amg:
1822 case dec_amg:
bbce6d69 1823 SvSetSV(left,res); return left;
dc437b57 1824 case not_amg:
fe7ac86a 1825 ans=!SvTRUE(res); break;
a0d0e21e 1826 }
54310121 1827 return boolSV(ans);
748a9306
LW
1828 } else if (method==copy_amg) {
1829 if (!SvROK(res)) {
cea2e8a9 1830 Perl_croak(aTHX_ "Copy method did not return a reference");
748a9306
LW
1831 }
1832 return SvREFCNT_inc(SvRV(res));
a0d0e21e
LW
1833 } else {
1834 return res;
1835 }
1836 }
1837}
c9d5ac95
GS
1838
1839/*
7fc63493 1840=for apidoc is_gv_magical_sv
c9d5ac95 1841
7a5fd60d
NC
1842Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1843
1844=cut
1845*/
1846
1847bool
1848Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1849{
1850 STRLEN len;
e1ec3a88 1851 const char *temp = SvPV(name, len);
7a5fd60d
NC
1852 return is_gv_magical(temp, len, flags);
1853}
1854
1855/*
1856=for apidoc is_gv_magical
1857
c9d5ac95
GS
1858Returns C<TRUE> if given the name of a magical GV.
1859
1860Currently only useful internally when determining if a GV should be
1861created even in rvalue contexts.
1862
1863C<flags> is not used at present but available for future extension to
1864allow selecting particular classes of magical variable.
1865
b9b0e72c
NC
1866Currently assumes that C<name> is NUL terminated (as well as len being valid).
1867This assumption is met by all callers within the perl core, which all pass
1868pointers returned by SvPV.
1869
c9d5ac95
GS
1870=cut
1871*/
1872bool
7fc63493 1873Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
c9d5ac95 1874{
dd374669 1875 (void)flags;
b9b0e72c 1876 if (len > 1) {
9431620d 1877 const char *name1 = name + 1;
b9b0e72c
NC
1878 switch (*name) {
1879 case 'I':
9431620d 1880 if (len == 3 && name1[1] == 'S' && name[2] == 'A')
b9b0e72c
NC
1881 goto yes;
1882 break;
1883 case 'O':
9431620d 1884 if (len == 8 && strEQ(name1, "VERLOAD"))
b9b0e72c
NC
1885 goto yes;
1886 break;
1887 case 'S':
9431620d 1888 if (len == 3 && name[1] == 'I' && name[2] == 'G')
b9b0e72c
NC
1889 goto yes;
1890 break;
1891 /* Using ${^...} variables is likely to be sufficiently rare that
1892 it seems sensible to avoid the space hit of also checking the
1893 length. */
1894 case '\017': /* ${^OPEN} */
9431620d 1895 if (strEQ(name1, "PEN"))
b9b0e72c
NC
1896 goto yes;
1897 break;
1898 case '\024': /* ${^TAINT} */
9431620d 1899 if (strEQ(name1, "AINT"))
b9b0e72c
NC
1900 goto yes;
1901 break;
1902 case '\025': /* ${^UNICODE} */
9431620d 1903 if (strEQ(name1, "NICODE"))
b9b0e72c 1904 goto yes;
7cebcbc0
NC
1905 if (strEQ(name1, "TF8LOCALE"))
1906 goto yes;
b9b0e72c
NC
1907 break;
1908 case '\027': /* ${^WARNING_BITS} */
9431620d 1909 if (strEQ(name1, "ARNING_BITS"))
b9b0e72c
NC
1910 goto yes;
1911 break;
1912 case '1':
1913 case '2':
1914 case '3':
1915 case '4':
1916 case '5':
1917 case '6':
1918 case '7':
1919 case '8':
1920 case '9':
c9d5ac95 1921 {
7fc63493 1922 const char *end = name + len;
c9d5ac95
GS
1923 while (--end > name) {
1924 if (!isDIGIT(*end))
1925 return FALSE;
1926 }
b9b0e72c
NC
1927 goto yes;
1928 }
1929 }
1930 } else {
1931 /* Because we're already assuming that name is NUL terminated
1932 below, we can treat an empty name as "\0" */
1933 switch (*name) {
1934 case '&':
1935 case '`':
1936 case '\'':
1937 case ':':
1938 case '?':
1939 case '!':
1940 case '-':
1941 case '#':
1942 case '[':
1943 case '^':
1944 case '~':
1945 case '=':
1946 case '%':
1947 case '.':
1948 case '(':
1949 case ')':
1950 case '<':
1951 case '>':
1952 case ',':
1953 case '\\':
1954 case '/':
1955 case '|':
1956 case '+':
1957 case ';':
1958 case ']':
1959 case '\001': /* $^A */
1960 case '\003': /* $^C */
1961 case '\004': /* $^D */
1962 case '\005': /* $^E */
1963 case '\006': /* $^F */
1964 case '\010': /* $^H */
1965 case '\011': /* $^I, NOT \t in EBCDIC */
1966 case '\014': /* $^L */
1967 case '\016': /* $^N */
1968 case '\017': /* $^O */
1969 case '\020': /* $^P */
1970 case '\023': /* $^S */
1971 case '\024': /* $^T */
1972 case '\026': /* $^V */
1973 case '\027': /* $^W */
1974 case '1':
1975 case '2':
1976 case '3':
1977 case '4':
1978 case '5':
1979 case '6':
1980 case '7':
1981 case '8':
1982 case '9':
1983 yes:
1984 return TRUE;
1985 default:
1986 break;
c9d5ac95 1987 }
c9d5ac95
GS
1988 }
1989 return FALSE;
1990}