This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Lexical use open ... support:
[perl5.git] / gv.c
CommitLineData
a0d0e21e 1/* gv.c
79072805 2 *
3818b22b 3 * Copyright (c) 1991-2000, Larry Wall
79072805
LW
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
a0d0e21e
LW
8 */
9
10/*
11 * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure
12 * of your inquisitiveness, I shall spend all the rest of my days answering
13 * you. What more do you want to know?'
14 * 'The names of all the stars, and of all living things, and the whole
15 * history of Middle-earth and Over-heaven and of the Sundering Seas,'
16 * laughed Pippin.
79072805
LW
17 */
18
19#include "EXTERN.h"
864dbfa3 20#define PERL_IN_GV_C
79072805
LW
21#include "perl.h"
22
23GV *
864dbfa3 24Perl_gv_AVadd(pTHX_ register GV *gv)
79072805 25{
a0d0e21e 26 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
cea2e8a9 27 Perl_croak(aTHX_ "Bad symbol for array");
79072805
LW
28 if (!GvAV(gv))
29 GvAV(gv) = newAV();
30 return gv;
31}
32
33GV *
864dbfa3 34Perl_gv_HVadd(pTHX_ register GV *gv)
79072805 35{
a0d0e21e 36 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
cea2e8a9 37 Perl_croak(aTHX_ "Bad symbol for hash");
79072805 38 if (!GvHV(gv))
463ee0b2 39 GvHV(gv) = newHV();
79072805
LW
40 return gv;
41}
42
43GV *
864dbfa3 44Perl_gv_IOadd(pTHX_ register GV *gv)
a0d0e21e
LW
45{
46 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
cea2e8a9 47 Perl_croak(aTHX_ "Bad symbol for filehandle");
a0d0e21e
LW
48 if (!GvIOp(gv))
49 GvIOp(gv) = newIO();
50 return gv;
51}
52
53GV *
864dbfa3 54Perl_gv_fetchfile(pTHX_ const char *name)
79072805 55{
e858de61 56 dTHR;
53d95988
CS
57 char smallbuf[256];
58 char *tmpbuf;
8ebc5c01 59 STRLEN tmplen;
79072805
LW
60 GV *gv;
61
1d7c1841
GS
62 if (!PL_defstash)
63 return Nullgv;
64
53d95988
CS
65 tmplen = strlen(name) + 2;
66 if (tmplen < sizeof smallbuf)
67 tmpbuf = smallbuf;
68 else
69 New(603, tmpbuf, tmplen + 1, char);
70 tmpbuf[0] = '_';
71 tmpbuf[1] = '<';
72 strcpy(tmpbuf + 2, name);
3280af22 73 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
1d7c1841 74 if (!isGV(gv)) {
3280af22 75 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
1d7c1841
GS
76 sv_setpv(GvSV(gv), name);
77 if (PERLDB_LINE)
fd345fa8 78 hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, 'L');
1d7c1841 79 }
53d95988
CS
80 if (tmpbuf != smallbuf)
81 Safefree(tmpbuf);
79072805
LW
82 return gv;
83}
84
463ee0b2 85void
864dbfa3 86Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
463ee0b2 87{
0f15f207 88 dTHR;
463ee0b2 89 register GP *gp;
55d729e4
GS
90 bool doproto = SvTYPE(gv) > SVt_NULL;
91 char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
463ee0b2 92
dc437b57 93 sv_upgrade((SV*)gv, SVt_PVGV);
55d729e4
GS
94 if (SvLEN(gv)) {
95 if (proto) {
96 SvPVX(gv) = NULL;
97 SvLEN(gv) = 0;
98 SvPOK_off(gv);
99 } else
100 Safefree(SvPVX(gv));
101 }
44a8e56a 102 Newz(602, gp, 1, GP);
8990e307 103 GvGP(gv) = gp_ref(gp);
463ee0b2 104 GvSV(gv) = NEWSV(72,0);
1d7c1841
GS
105 GvLINE(gv) = CopLINE(PL_curcop);
106 GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
005a453c 107 GvCVGEN(gv) = 0;
463ee0b2 108 GvEGV(gv) = gv;
6662521e 109 sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0);
85aff577 110 GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
a0d0e21e 111 GvNAME(gv) = savepvn(name, len);
463ee0b2 112 GvNAMELEN(gv) = len;
23ad5bf5 113 if (multi || doproto) /* doproto means it _was_ mentioned */
a5f75d66 114 GvMULTI_on(gv);
55d729e4 115 if (doproto) { /* Replicate part of newSUB here. */
57ff9a15 116 SvIOK_off(gv);
55d729e4 117 ENTER;
b099ddc0 118 /* XXX unsafe for threads if eval_owner isn't held */
55d729e4 119 start_subparse(0,0); /* Create CV in compcv. */
3280af22 120 GvCV(gv) = PL_compcv;
55d729e4
GS
121 LEAVE;
122
3280af22 123 PL_sub_generation++;
55d729e4 124 CvGV(GvCV(gv)) = (GV*)SvREFCNT_inc(gv);
1d7c1841 125 CvFILE(GvCV(gv)) = CopFILE(PL_curcop);
3280af22 126 CvSTASH(GvCV(gv)) = PL_curstash;
55d729e4
GS
127#ifdef USE_THREADS
128 CvOWNER(GvCV(gv)) = 0;
1cfa4ec7 129 if (!CvMUTEXP(GvCV(gv))) {
b0a484d2 130 New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
1cfa4ec7
GS
131 MUTEX_INIT(CvMUTEXP(GvCV(gv)));
132 }
55d729e4
GS
133#endif /* USE_THREADS */
134 if (proto) {
135 sv_setpv((SV*)GvCV(gv), proto);
136 Safefree(proto);
137 }
138 }
463ee0b2
LW
139}
140
76e3520e 141STATIC void
cea2e8a9 142S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
a0d0e21e
LW
143{
144 switch (sv_type) {
145 case SVt_PVIO:
146 (void)GvIOn(gv);
147 break;
148 case SVt_PVAV:
149 (void)GvAVn(gv);
150 break;
151 case SVt_PVHV:
152 (void)GvHVn(gv);
153 break;
154 }
155}
156
954c1994
GS
157/*
158=for apidoc gv_fetchmeth
159
160Returns the glob with the given C<name> and a defined subroutine or
161C<NULL>. The glob lives in the given C<stash>, or in the stashes
b267980d 162accessible via @ISA and @UNIVERSAL.
954c1994
GS
163
164The argument C<level> should be either 0 or -1. If C<level==0>, as a
165side-effect creates a glob with the given C<name> in the given C<stash>
166which in the case of success contains an alias for the subroutine, and sets
b267980d 167up caching info for this glob. Similarly for all the searched stashes.
954c1994
GS
168
169This function grants C<"SUPER"> token as a postfix of the stash name. The
170GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
4929bf7b 171visible to Perl code. So when calling C<call_sv>, you should not use
954c1994 172the GV directly; instead, you should use the method's CV, which can be
b267980d 173obtained from the GV with the C<GvCV> macro.
954c1994
GS
174
175=cut
176*/
177
79072805 178GV *
864dbfa3 179Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
79072805
LW
180{
181 AV* av;
463ee0b2 182 GV* topgv;
79072805 183 GV* gv;
463ee0b2 184 GV** gvp;
748a9306 185 CV* cv;
a0d0e21e
LW
186
187 if (!stash)
188 return 0;
44a8e56a 189 if ((level > 100) || (level < -100))
cea2e8a9 190 Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
3e0ccd42 191 name, HvNAME(stash));
463ee0b2 192
cea2e8a9 193 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
44a8e56a
PP
194
195 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
196 if (!gvp)
197 topgv = Nullgv;
198 else {
199 topgv = *gvp;
200 if (SvTYPE(topgv) != SVt_PVGV)
201 gv_init(topgv, stash, name, len, TRUE);
155aba94 202 if ((cv = GvCV(topgv))) {
44a8e56a 203 /* If genuine method or valid cache entry, use it */
3280af22 204 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
7a4c00b4 205 return topgv;
44a8e56a
PP
206 /* Stale cached entry: junk it */
207 SvREFCNT_dec(cv);
208 GvCV(topgv) = cv = Nullcv;
209 GvCVGEN(topgv) = 0;
748a9306 210 }
3280af22 211 else if (GvCVGEN(topgv) == PL_sub_generation)
005a453c 212 return 0; /* cache indicates sub doesn't exist */
463ee0b2 213 }
79072805 214
9607fc9c 215 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
3280af22 216 av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
9607fc9c 217
fb73857a
PP
218 /* create and re-create @.*::SUPER::ISA on demand */
219 if (!av || !SvMAGIC(av)) {
9607fc9c
PP
220 char* packname = HvNAME(stash);
221 STRLEN packlen = strlen(packname);
222
223 if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
224 HV* basestash;
225
226 packlen -= 7;
227 basestash = gv_stashpvn(packname, packlen, TRUE);
228 gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
3280af22 229 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
e858de61 230 dTHR; /* just for SvREFCNT_dec */
9607fc9c
PP
231 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
232 if (!gvp || !(gv = *gvp))
cea2e8a9 233 Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
9607fc9c
PP
234 if (SvTYPE(gv) != SVt_PVGV)
235 gv_init(gv, stash, "ISA", 3, TRUE);
236 SvREFCNT_dec(GvAV(gv));
237 GvAV(gv) = (AV*)SvREFCNT_inc(av);
238 }
239 }
240 }
241
242 if (av) {
79072805 243 SV** svp = AvARRAY(av);
93965878
NIS
244 /* NOTE: No support for tied ISA */
245 I32 items = AvFILLp(av) + 1;
79072805 246 while (items--) {
79072805 247 SV* sv = *svp++;
a0d0e21e 248 HV* basestash = gv_stashsv(sv, FALSE);
9bbf4081 249 if (!basestash) {
d008e5eb 250 dTHR; /* just for ckWARN */
599cee73 251 if (ckWARN(WARN_MISC))
cea2e8a9 252 Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA",
463ee0b2 253 SvPVX(sv), HvNAME(stash));
79072805
LW
254 continue;
255 }
44a8e56a
PP
256 gv = gv_fetchmeth(basestash, name, len,
257 (level >= 0) ? level + 1 : level - 1);
258 if (gv)
259 goto gotcha;
79072805
LW
260 }
261 }
a0d0e21e 262
9607fc9c
PP
263 /* if at top level, try UNIVERSAL */
264
44a8e56a 265 if (level == 0 || level == -1) {
9607fc9c
PP
266 HV* lastchance;
267
155aba94
GS
268 if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
269 if ((gv = gv_fetchmeth(lastchance, name, len,
270 (level >= 0) ? level + 1 : level - 1)))
271 {
44a8e56a 272 gotcha:
dc848c6f
PP
273 /*
274 * Cache method in topgv if:
275 * 1. topgv has no synonyms (else inheritance crosses wires)
276 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
277 */
278 if (topgv &&
279 GvREFCNT(topgv) == 1 &&
280 (cv = GvCV(gv)) &&
281 (CvROOT(cv) || CvXSUB(cv)))
282 {
155aba94 283 if ((cv = GvCV(topgv)))
44a8e56a
PP
284 SvREFCNT_dec(cv);
285 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
3280af22 286 GvCVGEN(topgv) = PL_sub_generation;
44a8e56a 287 }
a0d0e21e
LW
288 return gv;
289 }
005a453c
JP
290 else if (topgv && GvREFCNT(topgv) == 1) {
291 /* cache the fact that the method is not defined */
3280af22 292 GvCVGEN(topgv) = PL_sub_generation;
005a453c 293 }
a0d0e21e
LW
294 }
295 }
296
79072805
LW
297 return 0;
298}
299
954c1994
GS
300/*
301=for apidoc gv_fetchmethod
302
6d0f518e 303See L<gv_fetchmethod_autoload>.
954c1994
GS
304
305=cut
306*/
307
79072805 308GV *
864dbfa3 309Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
463ee0b2 310{
dc848c6f
PP
311 return gv_fetchmethod_autoload(stash, name, TRUE);
312}
313
954c1994
GS
314/*
315=for apidoc gv_fetchmethod_autoload
316
317Returns the glob which contains the subroutine to call to invoke the method
318on the C<stash>. In fact in the presence of autoloading this may be the
319glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
b267980d 320already setup.
954c1994
GS
321
322The third parameter of C<gv_fetchmethod_autoload> determines whether
323AUTOLOAD lookup is performed if the given method is not present: non-zero
b267980d 324means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
954c1994 325Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
b267980d 326with a non-zero C<autoload> parameter.
954c1994
GS
327
328These functions grant C<"SUPER"> token as a prefix of the method name. Note
329that if you want to keep the returned glob for a long time, you need to
330check for it being "AUTOLOAD", since at the later time the call may load a
331different subroutine due to $AUTOLOAD changing its value. Use the glob
b267980d 332created via a side effect to do this.
954c1994
GS
333
334These functions have the same side-effects and as C<gv_fetchmeth> with
335C<level==0>. C<name> should be writable if contains C<':'> or C<'
336''>. The warning against passing the GV returned by C<gv_fetchmeth> to
b267980d 337C<call_sv> apply equally to these functions.
954c1994
GS
338
339=cut
340*/
341
dc848c6f 342GV *
864dbfa3 343Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
dc848c6f 344{
0f15f207 345 dTHR;
08105a92
GS
346 register const char *nend;
347 const char *nsplit = 0;
a0d0e21e 348 GV* gv;
b267980d 349
463ee0b2 350 for (nend = name; *nend; nend++) {
9607fc9c 351 if (*nend == '\'')
a0d0e21e 352 nsplit = nend;
9607fc9c
PP
353 else if (*nend == ':' && *(nend + 1) == ':')
354 nsplit = ++nend;
a0d0e21e
LW
355 }
356 if (nsplit) {
08105a92 357 const char *origname = name;
a0d0e21e 358 name = nsplit + 1;
a0d0e21e
LW
359 if (*nsplit == ':')
360 --nsplit;
9607fc9c
PP
361 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
362 /* ->SUPER::method should really be looked up in original stash */
cea2e8a9 363 SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
1d7c1841 364 CopSTASHPV(PL_curcop)));
9607fc9c 365 stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
cea2e8a9 366 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
9607fc9c 367 origname, HvNAME(stash), name) );
4633a7c4 368 }
9607fc9c
PP
369 else
370 stash = gv_stashpvn(origname, nsplit - origname, TRUE);
4633a7c4
LW
371 }
372
9607fc9c 373 gv = gv_fetchmeth(stash, name, nend - name, 0);
a0d0e21e 374 if (!gv) {
2f6e0fe7 375 if (strEQ(name,"import") || strEQ(name,"unimport"))
3280af22 376 gv = (GV*)&PL_sv_yes;
dc848c6f 377 else if (autoload)
54310121 378 gv = gv_autoload4(stash, name, nend - name, TRUE);
463ee0b2 379 }
dc848c6f
PP
380 else if (autoload) {
381 CV* cv = GvCV(gv);
09280a33
CS
382 if (!CvROOT(cv) && !CvXSUB(cv)) {
383 GV* stubgv;
384 GV* autogv;
385
386 if (CvANON(cv))
387 stubgv = gv;
388 else {
389 stubgv = CvGV(cv);
390 if (GvCV(stubgv) != cv) /* orphaned import */
391 stubgv = gv;
392 }
393 autogv = gv_autoload4(GvSTASH(stubgv),
394 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
dc848c6f
PP
395 if (autogv)
396 gv = autogv;
397 }
398 }
44a8e56a
PP
399
400 return gv;
401}
402
403GV*
864dbfa3 404Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
44a8e56a 405{
d008e5eb 406 dTHR;
44a8e56a
PP
407 static char autoload[] = "AUTOLOAD";
408 static STRLEN autolen = 8;
409 GV* gv;
410 CV* cv;
411 HV* varstash;
412 GV* vargv;
413 SV* varsv;
414
415 if (len == autolen && strnEQ(name, autoload, autolen))
416 return Nullgv;
dc848c6f
PP
417 if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
418 return Nullgv;
419 cv = GvCV(gv);
420
ed850460
JH
421 if (!CvROOT(cv))
422 return Nullgv;
423
dc848c6f
PP
424 /*
425 * Inheriting AUTOLOAD for non-methods works ... for now.
426 */
b267980d 427 if (ckWARN(WARN_DEPRECATED) && !method &&
599cee73 428 (GvCVGEN(gv) || GvSTASH(gv) != stash))
cea2e8a9 429 Perl_warner(aTHX_ WARN_DEPRECATED,
dc848c6f
PP
430 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
431 HvNAME(stash), (int)len, name);
44a8e56a
PP
432
433 /*
434 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
435 * The subroutine's original name may not be "AUTOLOAD", so we don't
436 * use that, but for lack of anything better we will use the sub's
437 * original package to look up $AUTOLOAD.
438 */
439 varstash = GvSTASH(CvGV(cv));
440 vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
3d35f11b
GS
441 ENTER;
442
443#ifdef USE_THREADS
4755096e 444 sv_lock((SV *)varstash);
3d35f11b 445#endif
44a8e56a
PP
446 if (!isGV(vargv))
447 gv_init(vargv, varstash, autoload, autolen, FALSE);
3d35f11b 448 LEAVE;
44a8e56a 449 varsv = GvSV(vargv);
3d35f11b 450#ifdef USE_THREADS
4755096e 451 sv_lock(varsv);
3d35f11b 452#endif
44a8e56a
PP
453 sv_setpv(varsv, HvNAME(stash));
454 sv_catpvn(varsv, "::", 2);
455 sv_catpvn(varsv, name, len);
456 SvTAINTED_off(varsv);
a0d0e21e
LW
457 return gv;
458}
459
954c1994
GS
460/*
461=for apidoc gv_stashpv
462
386d01d6
GS
463Returns a pointer to the stash for a specified package. C<name> should
464be a valid UTF-8 string. If C<create> is set then the package will be
465created if it does not already exist. If C<create> is not set and the
466package does not exist then NULL is returned.
954c1994
GS
467
468=cut
469*/
470
a0d0e21e 471HV*
864dbfa3 472Perl_gv_stashpv(pTHX_ const char *name, I32 create)
a0d0e21e 473{
dc437b57
PP
474 return gv_stashpvn(name, strlen(name), create);
475}
476
477HV*
864dbfa3 478Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
dc437b57 479{
46fc3d4c
PP
480 char smallbuf[256];
481 char *tmpbuf;
a0d0e21e
LW
482 HV *stash;
483 GV *tmpgv;
dc437b57 484
46fc3d4c
PP
485 if (namelen + 3 < sizeof smallbuf)
486 tmpbuf = smallbuf;
487 else
488 New(606, tmpbuf, namelen + 3, char);
dc437b57
PP
489 Copy(name,tmpbuf,namelen,char);
490 tmpbuf[namelen++] = ':';
491 tmpbuf[namelen++] = ':';
492 tmpbuf[namelen] = '\0';
46fc3d4c
PP
493 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
494 if (tmpbuf != smallbuf)
495 Safefree(tmpbuf);
a0d0e21e
LW
496 if (!tmpgv)
497 return 0;
498 if (!GvHV(tmpgv))
499 GvHV(tmpgv) = newHV();
500 stash = GvHV(tmpgv);
501 if (!HvNAME(stash))
502 HvNAME(stash) = savepv(name);
503 return stash;
463ee0b2
LW
504}
505
954c1994
GS
506/*
507=for apidoc gv_stashsv
508
386d01d6
GS
509Returns a pointer to the stash for a specified package, which must be a
510valid UTF-8 string. See C<gv_stashpv>.
954c1994
GS
511
512=cut
513*/
514
a0d0e21e 515HV*
864dbfa3 516Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
a0d0e21e 517{
dc437b57
PP
518 register char *ptr;
519 STRLEN len;
520 ptr = SvPV(sv,len);
521 return gv_stashpvn(ptr, len, create);
a0d0e21e
LW
522}
523
524
463ee0b2 525GV *
864dbfa3 526Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
79072805 527{
11343788 528 dTHR;
08105a92 529 register const char *name = nambeg;
463ee0b2 530 register GV *gv = 0;
79072805 531 GV**gvp;
79072805 532 I32 len;
08105a92 533 register const char *namend;
463ee0b2 534 HV *stash = 0;
79072805 535
c07a80fd
PP
536 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
537 name++;
538
79072805 539 for (namend = name; *namend; namend++) {
1d7c1841
GS
540 if ((*namend == ':' && namend[1] == ':')
541 || (*namend == '\'' && namend[1]))
463ee0b2 542 {
463ee0b2 543 if (!stash)
3280af22 544 stash = PL_defstash;
dc437b57 545 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
a0d0e21e 546 return Nullgv;
463ee0b2 547
85e6fe83
LW
548 len = namend - name;
549 if (len > 0) {
3c78fafa 550 char smallbuf[256];
62b57502 551 char *tmpbuf;
62b57502 552
3c78fafa
GS
553 if (len + 3 < sizeof smallbuf)
554 tmpbuf = smallbuf;
62b57502
MB
555 else
556 New(601, tmpbuf, len+3, char);
a0d0e21e
LW
557 Copy(name, tmpbuf, len, char);
558 tmpbuf[len++] = ':';
559 tmpbuf[len++] = ':';
560 tmpbuf[len] = '\0';
463ee0b2 561 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
6fa846a0 562 gv = gvp ? *gvp : Nullgv;
3280af22 563 if (gv && gv != (GV*)&PL_sv_undef) {
6fa846a0 564 if (SvTYPE(gv) != SVt_PVGV)
0f303493 565 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
6fa846a0
GS
566 else
567 GvMULTI_on(gv);
568 }
3c78fafa 569 if (tmpbuf != smallbuf)
62b57502 570 Safefree(tmpbuf);
3280af22 571 if (!gv || gv == (GV*)&PL_sv_undef)
a0d0e21e 572 return Nullgv;
85e6fe83 573
463ee0b2
LW
574 if (!(stash = GvHV(gv)))
575 stash = GvHV(gv) = newHV();
85e6fe83 576
463ee0b2 577 if (!HvNAME(stash))
a0d0e21e 578 HvNAME(stash) = savepvn(nambeg, namend - nambeg);
463ee0b2
LW
579 }
580
581 if (*namend == ':')
582 namend++;
583 namend++;
584 name = namend;
585 if (!*name)
3280af22 586 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
79072805 587 }
79072805 588 }
a0d0e21e
LW
589 len = namend - name;
590 if (!len)
591 len = 1;
463ee0b2
LW
592
593 /* No stash in name, so see how we can default */
594
595 if (!stash) {
7e2040f0 596 if (isIDFIRST_lazy(name)) {
9607fc9c
PP
597 bool global = FALSE;
598
463ee0b2 599 if (isUPPER(*name)) {
9d116dd7
JH
600 if (*name == 'S' && (
601 strEQ(name, "SIG") ||
602 strEQ(name, "STDIN") ||
603 strEQ(name, "STDOUT") ||
604 strEQ(name, "STDERR")))
605 global = TRUE;
606 else if (*name == 'I' && strEQ(name, "INC"))
607 global = TRUE;
608 else if (*name == 'E' && strEQ(name, "ENV"))
609 global = TRUE;
463ee0b2
LW
610 else if (*name == 'A' && (
611 strEQ(name, "ARGV") ||
9d116dd7 612 strEQ(name, "ARGVOUT")))
463ee0b2
LW
613 global = TRUE;
614 }
615 else if (*name == '_' && !name[1])
616 global = TRUE;
9607fc9c 617
463ee0b2 618 if (global)
3280af22
NIS
619 stash = PL_defstash;
620 else if ((COP*)PL_curcop == &PL_compiling) {
621 stash = PL_curstash;
622 if (add && (PL_hints & HINT_STRICT_VARS) &&
748a9306
LW
623 sv_type != SVt_PVCV &&
624 sv_type != SVt_PVGV &&
4633a7c4 625 sv_type != SVt_PVFM &&
c07a80fd 626 sv_type != SVt_PVIO &&
377b8fbc 627 !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
748a9306 628 {
4633a7c4
LW
629 gvp = (GV**)hv_fetch(stash,name,len,0);
630 if (!gvp ||
3280af22 631 *gvp == (GV*)&PL_sv_undef ||
a5f75d66
AD
632 SvTYPE(*gvp) != SVt_PVGV)
633 {
4633a7c4 634 stash = 0;
a5f75d66 635 }
155aba94
GS
636 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
637 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
638 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
4633a7c4 639 {
cea2e8a9 640 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
4633a7c4
LW
641 sv_type == SVt_PVAV ? '@' :
642 sv_type == SVt_PVHV ? '%' : '$',
643 name);
8ebc5c01 644 if (GvCVu(*gvp))
cc507455 645 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
a0d0e21e 646 stash = 0;
4633a7c4 647 }
a0d0e21e 648 }
85e6fe83 649 }
463ee0b2 650 else
1d7c1841 651 stash = CopSTASH(PL_curcop);
463ee0b2
LW
652 }
653 else
3280af22 654 stash = PL_defstash;
463ee0b2
LW
655 }
656
657 /* By this point we should have a stash and a name */
658
a0d0e21e 659 if (!stash) {
5a844595
GS
660 if (add) {
661 qerror(Perl_mess(aTHX_
662 "Global symbol \"%s%s\" requires explicit package name",
663 (sv_type == SVt_PV ? "$"
664 : sv_type == SVt_PVAV ? "@"
665 : sv_type == SVt_PVHV ? "%"
666 : ""), name));
f180df80 667 stash = PL_nullstash;
a0d0e21e 668 }
f180df80
GS
669 else
670 return Nullgv;
a0d0e21e
LW
671 }
672
673 if (!SvREFCNT(stash)) /* symbol table under destruction */
674 return Nullgv;
675
79072805 676 gvp = (GV**)hv_fetch(stash,name,len,add);
3280af22 677 if (!gvp || *gvp == (GV*)&PL_sv_undef)
79072805
LW
678 return Nullgv;
679 gv = *gvp;
680 if (SvTYPE(gv) == SVt_PVGV) {
a0d0e21e 681 if (add) {
a5f75d66 682 GvMULTI_on(gv);
a0d0e21e
LW
683 gv_init_sv(gv, sv_type);
684 }
79072805 685 return gv;
55d729e4
GS
686 } else if (add & GV_NOINIT) {
687 return gv;
79072805 688 }
93a17b20
LW
689
690 /* Adding a new symbol */
691
0453d815
PM
692 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
693 Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg);
55d729e4 694 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
a0d0e21e 695 gv_init_sv(gv, sv_type);
93a17b20 696
0453d815
PM
697 if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE))
698 GvMULTI_on(gv) ;
699
93a17b20
LW
700 /* set up magic where warranted */
701 switch (*name) {
a0d0e21e
LW
702 case 'A':
703 if (strEQ(name, "ARGV")) {
704 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
705 }
706 break;
a0d0e21e
LW
707 case 'E':
708 if (strnEQ(name, "EXPORT", 6))
a5f75d66 709 GvMULTI_on(gv);
a0d0e21e 710 break;
463ee0b2
LW
711 case 'I':
712 if (strEQ(name, "ISA")) {
713 AV* av = GvAVn(gv);
a5f75d66 714 GvMULTI_on(gv);
a0d0e21e 715 sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
93965878 716 /* NOTE: No support for tied ISA */
55d729e4
GS
717 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
718 && AvFILLp(av) == -1)
85e6fe83 719 {
a0d0e21e 720 char *pname;
79cb57f6 721 av_push(av, newSVpvn(pname = "NDBM_File",9));
dc437b57 722 gv_stashpvn(pname, 9, TRUE);
79cb57f6 723 av_push(av, newSVpvn(pname = "DB_File",7));
dc437b57 724 gv_stashpvn(pname, 7, TRUE);
79cb57f6 725 av_push(av, newSVpvn(pname = "GDBM_File",9));
dc437b57 726 gv_stashpvn(pname, 9, TRUE);
79cb57f6 727 av_push(av, newSVpvn(pname = "SDBM_File",9));
dc437b57 728 gv_stashpvn(pname, 9, TRUE);
79cb57f6 729 av_push(av, newSVpvn(pname = "ODBM_File",9));
dc437b57 730 gv_stashpvn(pname, 9, TRUE);
85e6fe83 731 }
463ee0b2
LW
732 }
733 break;
a0d0e21e
LW
734 case 'O':
735 if (strEQ(name, "OVERLOAD")) {
736 HV* hv = GvHVn(gv);
a5f75d66 737 GvMULTI_on(gv);
fd345fa8 738 hv_magic(hv, Nullgv, 'A');
a0d0e21e
LW
739 }
740 break;
93a17b20
LW
741 case 'S':
742 if (strEQ(name, "SIG")) {
743 HV *hv;
dc437b57 744 I32 i;
1d7c1841
GS
745 if (!PL_psig_ptr) {
746 int sig_num[] = { SIG_NUM };
747 New(73, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
748 New(73, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
749 }
750 GvMULTI_on(gv);
751 hv = GvHVn(gv);
fd345fa8 752 hv_magic(hv, Nullgv, 'S');
1d7c1841 753 for (i = 1; PL_sig_name[i]; i++) {
dc437b57 754 SV ** init;
1d7c1841
GS
755 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
756 if (init)
757 sv_setsv(*init, &PL_sv_undef);
22c35a8c
GS
758 PL_psig_ptr[i] = 0;
759 PL_psig_name[i] = 0;
dc437b57 760 }
93a17b20
LW
761 }
762 break;
09bef843
SB
763 case 'V':
764 if (strEQ(name, "VERSION"))
765 GvMULTI_on(gv);
766 break;
93a17b20
LW
767
768 case '&':
463ee0b2
LW
769 if (len > 1)
770 break;
3280af22 771 PL_sawampersand = TRUE;
a0d0e21e 772 goto ro_magicalize;
93a17b20
LW
773
774 case '`':
463ee0b2
LW
775 if (len > 1)
776 break;
3280af22 777 PL_sawampersand = TRUE;
a0d0e21e 778 goto ro_magicalize;
93a17b20
LW
779
780 case '\'':
463ee0b2
LW
781 if (len > 1)
782 break;
3280af22 783 PL_sawampersand = TRUE;
a0d0e21e 784 goto ro_magicalize;
93a17b20
LW
785
786 case ':':
463ee0b2
LW
787 if (len > 1)
788 break;
3280af22 789 sv_setpv(GvSV(gv),PL_chopset);
93a17b20
LW
790 goto magicalize;
791
ff0cee69
PP
792 case '?':
793 if (len > 1)
794 break;
795#ifdef COMPLEX_STATUS
07f14f54 796 (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
ff0cee69
PP
797#endif
798 goto magicalize;
799
067391ea 800 case '!':
4318d5a0 801 if (len > 1)
067391ea 802 break;
3280af22 803 if (sv_type > SVt_PV && PL_curcop != &PL_compiling) {
067391ea 804 HV* stash = gv_stashpvn("Errno",5,FALSE);
265f5c4a 805 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
067391ea
GS
806 dSP;
807 PUTBACK;
cea2e8a9 808 require_pv("Errno.pm");
067391ea
GS
809 SPAGAIN;
810 stash = gv_stashpvn("Errno",5,FALSE);
811 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
cea2e8a9 812 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
067391ea
GS
813 }
814 }
815 goto magicalize;
6cef1e77
IZ
816 case '-':
817 if (len > 1)
818 break;
819 else {
820 AV* av = GvAVn(gv);
821 sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
03a27ae7 822 SvREADONLY_on(av);
6cef1e77
IZ
823 }
824 goto magicalize;
93a17b20 825 case '#':
a0d0e21e 826 case '*':
599cee73 827 if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
cea2e8a9 828 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
a0d0e21e
LW
829 /* FALL THROUGH */
830 case '[':
93a17b20
LW
831 case '^':
832 case '~':
833 case '=':
93a17b20
LW
834 case '%':
835 case '.':
93a17b20
LW
836 case '(':
837 case ')':
838 case '<':
839 case '>':
840 case ',':
841 case '\\':
842 case '/':
93a17b20 843 case '|':
16070b82
GS
844 case '\001': /* $^A */
845 case '\003': /* $^C */
846 case '\004': /* $^D */
847 case '\005': /* $^E */
848 case '\006': /* $^F */
849 case '\010': /* $^H */
850 case '\011': /* $^I, NOT \t in EBCDIC */
16070b82
GS
851 case '\020': /* $^P */
852 case '\024': /* $^T */
463ee0b2
LW
853 if (len > 1)
854 break;
855 goto magicalize;
ac27b0f5
NIS
856 case '\017': /* $^O & $^OPEN */
857 if (len > 1 && strNE(name, "\017PEN"))
858 break;
859 goto magicalize;
16070b82 860 case '\023': /* $^S */
6cef1e77
IZ
861 if (len > 1)
862 break;
863 goto ro_magicalize;
6a818117 864 case '\027': /* $^W & $^WARNING_BITS */
a50e31ad
GS
865 if (len > 1 && strNE(name, "\027ARNING_BITS")
866 && strNE(name, "\027IDE_SYSTEM_CALLS"))
4438c4b7
JH
867 break;
868 goto magicalize;
463ee0b2 869
a0d0e21e 870 case '+':
6cef1e77
IZ
871 if (len > 1)
872 break;
873 else {
874 AV* av = GvAVn(gv);
875 sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
03a27ae7 876 SvREADONLY_on(av);
6cef1e77
IZ
877 }
878 /* FALL THROUGH */
463ee0b2
LW
879 case '1':
880 case '2':
881 case '3':
882 case '4':
883 case '5':
884 case '6':
885 case '7':
886 case '8':
887 case '9':
a0d0e21e
LW
888 ro_magicalize:
889 SvREADONLY_on(GvSV(gv));
93a17b20 890 magicalize:
463ee0b2 891 sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
93a17b20
LW
892 break;
893
16070b82 894 case '\014': /* $^L */
463ee0b2
LW
895 if (len > 1)
896 break;
93a17b20 897 sv_setpv(GvSV(gv),"\f");
3280af22 898 PL_formfeed = GvSV(gv);
93a17b20
LW
899 break;
900 case ';':
463ee0b2
LW
901 if (len > 1)
902 break;
93a17b20
LW
903 sv_setpv(GvSV(gv),"\034");
904 break;
463ee0b2
LW
905 case ']':
906 if (len == 1) {
f86702cc 907 SV *sv = GvSV(gv);
5089c844 908 (void)SvUPGRADE(sv, SVt_PVNV);
6a6ba966
SB
909 Perl_sv_setpvf(aTHX_ sv,
910#if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
911 "%8.6"
912#else
913 "%5.3"
914#endif
915 NVff,
916 SvNVX(PL_patchlevel));
5089c844
GS
917 SvNVX(sv) = SvNVX(PL_patchlevel);
918 SvNOK_on(sv);
5089c844 919 SvREADONLY_on(sv);
93a17b20
LW
920 }
921 break;
16070b82
GS
922 case '\026': /* $^V */
923 if (len == 1) {
924 SV *sv = GvSV(gv);
925 GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
926 SvREFCNT_dec(sv);
927 }
928 break;
79072805 929 }
93a17b20 930 return gv;
79072805
LW
931}
932
933void
43693395
GS
934Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
935{
936 HV *hv = GvSTASH(gv);
937 if (!hv) {
938 (void)SvOK_off(sv);
939 return;
940 }
941 sv_setpv(sv, prefix ? prefix : "");
942 if (keepmain || strNE(HvNAME(hv), "main")) {
943 sv_catpv(sv,HvNAME(hv));
944 sv_catpvn(sv,"::", 2);
945 }
946 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
947}
948
949void
864dbfa3 950Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
79072805
LW
951{
952 HV *hv = GvSTASH(gv);
f967eb5f 953 if (!hv) {
155aba94 954 (void)SvOK_off(sv);
79072805 955 return;
f967eb5f
PP
956 }
957 sv_setpv(sv, prefix ? prefix : "");
79072805 958 sv_catpv(sv,HvNAME(hv));
463ee0b2 959 sv_catpvn(sv,"::", 2);
79072805
LW
960 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
961}
962
963void
43693395
GS
964Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
965{
966 GV *egv = GvEGV(gv);
967 if (!egv)
968 egv = gv;
969 gv_fullname4(sv, egv, prefix, keepmain);
970}
971
972void
864dbfa3 973Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
79072805 974{
f967eb5f 975 GV *egv = GvEGV(gv);
748a9306
LW
976 if (!egv)
977 egv = gv;
f6aff53a
PP
978 gv_fullname3(sv, egv, prefix);
979}
980
981/* XXX compatibility with versions <= 5.003. */
982void
864dbfa3 983Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
f6aff53a
PP
984{
985 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
986}
987
988/* XXX compatibility with versions <= 5.003. */
989void
864dbfa3 990Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
f6aff53a
PP
991{
992 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
79072805
LW
993}
994
995IO *
864dbfa3 996Perl_newIO(pTHX)
79072805 997{
11343788 998 dTHR;
79072805 999 IO *io;
8990e307
LW
1000 GV *iogv;
1001
1002 io = (IO*)NEWSV(0,0);
a0d0e21e 1003 sv_upgrade((SV *)io,SVt_PVIO);
8990e307
LW
1004 SvREFCNT(io) = 1;
1005 SvOBJECT_on(io);
c9de509e 1006 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
5f2d631d
GS
1007 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1008 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
c9de509e 1009 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
8990e307 1010 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
79072805
LW
1011 return io;
1012}
1013
1014void
864dbfa3 1015Perl_gv_check(pTHX_ HV *stash)
79072805 1016{
11343788 1017 dTHR;
79072805
LW
1018 register HE *entry;
1019 register I32 i;
1020 register GV *gv;
463ee0b2
LW
1021 HV *hv;
1022
8990e307
LW
1023 if (!HvARRAY(stash))
1024 return;
a0d0e21e 1025 for (i = 0; i <= (I32) HvMAX(stash); i++) {
dc437b57
PP
1026 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1027 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1028 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
a0d0e21e 1029 {
19b6c847 1030 if (hv != PL_defstash && hv != stash)
a0d0e21e
LW
1031 gv_check(hv); /* nested package */
1032 }
dc437b57 1033 else if (isALPHA(*HeKEY(entry))) {
1d7c1841 1034 char *file;
dc437b57 1035 gv = (GV*)HeVAL(entry);
55d729e4 1036 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
463ee0b2 1037 continue;
1d7c1841
GS
1038 file = GvFILE(gv);
1039 /* performance hack: if filename is absolute and it's a standard
1040 * module, don't bother warning */
1041 if (file
1042 && PERL_FILE_IS_ABSOLUTE(file)
1043 && (instr(file, "/lib/") || instr(file, ".pm")))
1044 {
8990e307 1045 continue;
1d7c1841
GS
1046 }
1047 CopLINE_set(PL_curcop, GvLINE(gv));
1048#ifdef USE_ITHREADS
1049 CopFILE(PL_curcop) = file; /* set for warning */
1050#else
1051 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1052#endif
cea2e8a9 1053 Perl_warner(aTHX_ WARN_ONCE,
599cee73 1054 "Name \"%s::%s\" used only once: possible typo",
a0d0e21e 1055 HvNAME(stash), GvNAME(gv));
463ee0b2 1056 }
79072805
LW
1057 }
1058 }
1059}
1060
1061GV *
864dbfa3 1062Perl_newGVgen(pTHX_ char *pack)
79072805 1063{
cea2e8a9 1064 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
46fc3d4c 1065 TRUE, SVt_PVGV);
79072805
LW
1066}
1067
1068/* hopefully this is only called on local symbol table entries */
1069
1070GP*
864dbfa3 1071Perl_gp_ref(pTHX_ GP *gp)
79072805 1072{
1d7c1841
GS
1073 if (!gp)
1074 return (GP*)NULL;
79072805 1075 gp->gp_refcnt++;
44a8e56a
PP
1076 if (gp->gp_cv) {
1077 if (gp->gp_cvgen) {
1078 /* multi-named GPs cannot be used for method cache */
1079 SvREFCNT_dec(gp->gp_cv);
1080 gp->gp_cv = Nullcv;
1081 gp->gp_cvgen = 0;
1082 }
1083 else {
1084 /* Adding a new name to a subroutine invalidates method cache */
3280af22 1085 PL_sub_generation++;
44a8e56a
PP
1086 }
1087 }
79072805 1088 return gp;
79072805
LW
1089}
1090
1091void
864dbfa3 1092Perl_gp_free(pTHX_ GV *gv)
79072805 1093{
b267980d 1094 dTHR;
79072805
LW
1095 GP* gp;
1096
1097 if (!gv || !(gp = GvGP(gv)))
1098 return;
f248d071
GS
1099 if (gp->gp_refcnt == 0) {
1100 if (ckWARN_d(WARN_INTERNAL))
1101 Perl_warner(aTHX_ WARN_INTERNAL,
1102 "Attempt to free unreferenced glob pointers");
79072805
LW
1103 return;
1104 }
44a8e56a
PP
1105 if (gp->gp_cv) {
1106 /* Deleting the name of a subroutine invalidates method cache */
3280af22 1107 PL_sub_generation++;
44a8e56a 1108 }
748a9306
LW
1109 if (--gp->gp_refcnt > 0) {
1110 if (gp->gp_egv == gv)
1111 gp->gp_egv = 0;
79072805 1112 return;
748a9306 1113 }
79072805 1114
8990e307
LW
1115 SvREFCNT_dec(gp->gp_sv);
1116 SvREFCNT_dec(gp->gp_av);
1117 SvREFCNT_dec(gp->gp_hv);
377b8fbc 1118 SvREFCNT_dec(gp->gp_io);
a6006777 1119 SvREFCNT_dec(gp->gp_cv);
748a9306
LW
1120 SvREFCNT_dec(gp->gp_form);
1121
79072805
LW
1122 Safefree(gp);
1123 GvGP(gv) = 0;
1124}
1125
1126#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1127#define MICROPORT
1128#endif
1129
1130#ifdef MICROPORT /* Microport 2.4 hack */
1131AV *GvAVn(gv)
1132register GV *gv;
1133{
b267980d 1134 if (GvGP(gv)->gp_av)
79072805
LW
1135 return GvGP(gv)->gp_av;
1136 else
1137 return GvGP(gv_AVadd(gv))->gp_av;
1138}
1139
1140HV *GvHVn(gv)
1141register GV *gv;
1142{
1143 if (GvGP(gv)->gp_hv)
1144 return GvGP(gv)->gp_hv;
1145 else
1146 return GvGP(gv_HVadd(gv))->gp_hv;
1147}
1148#endif /* Microport 2.4 hack */
a0d0e21e 1149
a0d0e21e
LW
1150/* Updates and caches the CV's */
1151
1152bool
864dbfa3 1153Perl_Gv_AMupdate(pTHX_ HV *stash)
a0d0e21e 1154{
155aba94 1155 dTHR;
a0d0e21e
LW
1156 GV* gv;
1157 CV* cv;
1158 MAGIC* mg=mg_find((SV*)stash,'c');
8ac85365 1159 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
a6006777 1160 AMT amt;
2d8e6c8d 1161 STRLEN n_a;
155aba94
GS
1162#ifdef OVERLOAD_VIA_HASH
1163 GV** gvp;
1164 HV* hv;
1165#endif
a0d0e21e 1166
3280af22
NIS
1167 if (mg && amtp->was_ok_am == PL_amagic_generation
1168 && amtp->was_ok_sub == PL_sub_generation)
a6006777
PP
1169 return AMT_AMAGIC(amtp);
1170 if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */
748a9306 1171 int i;
a6006777 1172 for (i=1; i<NofAMmeth; i++) {
748a9306
LW
1173 if (amtp->table[i]) {
1174 SvREFCNT_dec(amtp->table[i]);
1175 }
1176 }
1177 }
a0d0e21e
LW
1178 sv_unmagic((SV*)stash, 'c');
1179
cea2e8a9 1180 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
a0d0e21e 1181
3280af22
NIS
1182 amt.was_ok_am = PL_amagic_generation;
1183 amt.was_ok_sub = PL_sub_generation;
a6006777
PP
1184 amt.fallback = AMGfallNO;
1185 amt.flags = 0;
1186
1187#ifdef OVERLOAD_VIA_HASH
1188 gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
3280af22 1189 if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
a0d0e21e
LW
1190 int filled=0;
1191 int i;
1192 char *cp;
a0d0e21e
LW
1193 SV* sv;
1194 SV** svp;
a0d0e21e 1195
22c35a8c 1196 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
a0d0e21e 1197
22c35a8c 1198 if (( cp = (char *)PL_AMG_names[0] ) &&
a6006777 1199 (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
a0d0e21e
LW
1200 if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1201 else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1202 }
a6006777
PP
1203 for (i = 1; i < NofAMmeth; i++) {
1204 cv = 0;
22c35a8c 1205 cp = (char *)PL_AMG_names[i];
b267980d 1206
a6006777 1207 svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
3280af22 1208 if (svp && ((sv = *svp) != &PL_sv_undef)) {
a0d0e21e
LW
1209 switch (SvTYPE(sv)) {
1210 default:
1211 if (!SvROK(sv)) {
1212 if (!SvOK(sv)) break;
2d8e6c8d 1213 gv = gv_fetchmethod(stash, SvPV(sv, n_a));
a0d0e21e
LW
1214 if (gv) cv = GvCV(gv);
1215 break;
1216 }
1217 cv = (CV*)SvRV(sv);
1218 if (SvTYPE(cv) == SVt_PVCV)
1219 break;
1220 /* FALL THROUGH */
1221 case SVt_PVHV:
1222 case SVt_PVAV:
cea2e8a9 1223 Perl_croak(aTHX_ "Not a subroutine reference in overload table");
a0d0e21e
LW
1224 return FALSE;
1225 case SVt_PVCV:
8ebc5c01
PP
1226 cv = (CV*)sv;
1227 break;
a0d0e21e 1228 case SVt_PVGV:
8ebc5c01 1229 if (!(cv = GvCVu((GV*)sv)))
f6ec51f7 1230 cv = sv_2cv(sv, &stash, &gv, FALSE);
8ebc5c01 1231 break;
a0d0e21e
LW
1232 }
1233 if (cv) filled=1;
1234 else {
cea2e8a9 1235 Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
a0d0e21e
LW
1236 cp,HvNAME(stash));
1237 return FALSE;
1238 }
1239 }
a6006777
PP
1240#else
1241 {
1242 int filled = 0;
1243 int i;
9607fc9c 1244 const char *cp;
a6006777 1245 SV* sv = NULL;
a6006777 1246
22c35a8c 1247 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
a6006777 1248
155aba94 1249 if ((cp = PL_AMG_names[0])) {
a6006777 1250 /* Try to find via inheritance. */
774d564b 1251 gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
155aba94
GS
1252 if (gv)
1253 sv = GvSV(gv);
1254
1255 if (!gv)
1256 goto no_table;
1257 else if (SvTRUE(sv))
1258 amt.fallback=AMGfallYES;
1259 else if (SvOK(sv))
1260 amt.fallback=AMGfallNEVER;
a6006777
PP
1261 }
1262
1263 for (i = 1; i < NofAMmeth; i++) {
cea2e8a9
GS
1264 SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
1265 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
44a8e56a 1266 cp, HvNAME(stash)) );
46fc3d4c
PP
1267 /* don't fill the cache while looking up! */
1268 gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
1269 cv = 0;
44a8e56a 1270 if(gv && (cv = GvCV(gv))) {
44a8e56a
PP
1271 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1272 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1273 /* GvSV contains the name of the method. */
1274 GV *ngv;
1275
b267980d 1276 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
2d8e6c8d 1277 SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
b267980d 1278 if (!SvPOK(GvSV(gv))
dc848c6f
PP
1279 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1280 FALSE)))
1281 {
44a8e56a
PP
1282 /* Can be an import stub (created by `can'). */
1283 if (GvCVGEN(gv)) {
b267980d 1284 Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
44a8e56a
PP
1285 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1286 cp, HvNAME(stash));
1287 } else
b267980d 1288 Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
44a8e56a
PP
1289 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1290 cp, HvNAME(stash));
1291 }
dc848c6f 1292 cv = GvCV(gv = ngv);
44a8e56a 1293 }
cea2e8a9 1294 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
44a8e56a
PP
1295 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1296 GvNAME(CvGV(cv))) );
1297 filled = 1;
1298 }
b267980d 1299#endif
a6006777 1300 amt.table[i]=(CV*)SvREFCNT_inc(cv);
a0d0e21e 1301 }
a0d0e21e 1302 if (filled) {
a6006777
PP
1303 AMT_AMAGIC_on(&amt);
1304 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
a0d0e21e
LW
1305 return TRUE;
1306 }
1307 }
a6006777 1308 /* Here we have no table: */
774d564b 1309 no_table:
a6006777
PP
1310 AMT_AMAGIC_off(&amt);
1311 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
a0d0e21e
LW
1312 return FALSE;
1313}
1314
a0d0e21e 1315SV*
864dbfa3 1316Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
a0d0e21e 1317{
11343788 1318 dTHR;
b267980d
NIS
1319 MAGIC *mg;
1320 CV *cv;
a0d0e21e
LW
1321 CV **cvp=NULL, **ocvp=NULL;
1322 AMT *amtp, *oamtp;
1323 int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
ee239bfe 1324 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
a0d0e21e
LW
1325 HV* stash;
1326 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1327 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
b267980d 1328 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 1329 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
8ac85365 1330 : (CV **) NULL))
b267980d 1331 && ((cv = cvp[off=method+assignshift])
748a9306
LW
1332 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1333 * usual method */
1334 (fl = 1, cv = cvp[off=method])))) {
a0d0e21e
LW
1335 lr = -1; /* Call method for left argument */
1336 } else {
1337 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1338 int logic;
1339
1340 /* look for substituted methods */
ee239bfe 1341 /* In all the covered cases we should be called with assign==0. */
a0d0e21e
LW
1342 switch (method) {
1343 case inc_amg:
ee239bfe
IZ
1344 force_cpy = 1;
1345 if ((cv = cvp[off=add_ass_amg])
1346 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3280af22 1347 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1348 }
1349 break;
1350 case dec_amg:
ee239bfe
IZ
1351 force_cpy = 1;
1352 if ((cv = cvp[off = subtr_ass_amg])
1353 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3280af22 1354 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1355 }
1356 break;
1357 case bool__amg:
1358 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1359 break;
1360 case numer_amg:
1361 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1362 break;
1363 case string_amg:
1364 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1365 break;
dc437b57 1366 case not_amg:
b267980d 1367 (void)((cv = cvp[off=bool__amg])
dc437b57
PP
1368 || (cv = cvp[off=numer_amg])
1369 || (cv = cvp[off=string_amg]));
1370 postpr = 1;
1371 break;
748a9306
LW
1372 case copy_amg:
1373 {
76e3520e
GS
1374 /*
1375 * SV* ref causes confusion with the interpreter variable of
1376 * the same name
1377 */
1378 SV* tmpRef=SvRV(left);
1379 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
fc36a67e
PP
1380 /*
1381 * Just to be extra cautious. Maybe in some
1382 * additional cases sv_setsv is safe, too.
1383 */
76e3520e 1384 SV* newref = newSVsv(tmpRef);
748a9306 1385 SvOBJECT_on(newref);
76e3520e 1386 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
748a9306
LW
1387 return newref;
1388 }
1389 }
1390 break;
a0d0e21e 1391 case abs_amg:
b267980d 1392 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
a0d0e21e 1393 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
748a9306 1394 SV* nullsv=sv_2mortal(newSViv(0));
a0d0e21e 1395 if (off1==lt_amg) {
748a9306 1396 SV* lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1397 lt_amg,AMGf_noright);
1398 logic = SvTRUE(lessp);
1399 } else {
748a9306 1400 SV* lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1401 ncmp_amg,AMGf_noright);
1402 logic = (SvNV(lessp) < 0);
1403 }
1404 if (logic) {
1405 if (off==subtr_amg) {
1406 right = left;
748a9306 1407 left = nullsv;
a0d0e21e
LW
1408 lr = 1;
1409 }
1410 } else {
1411 return left;
1412 }
1413 }
1414 break;
1415 case neg_amg:
155aba94 1416 if ((cv = cvp[off=subtr_amg])) {
a0d0e21e
LW
1417 right = left;
1418 left = sv_2mortal(newSViv(0));
1419 lr = 1;
1420 }
1421 break;
f5284f61 1422 case iter_amg: /* XXXX Eventually should do to_gv. */
b267980d
NIS
1423 /* FAIL safe */
1424 return NULL; /* Delegate operation to standard mechanisms. */
1425 break;
f5284f61
IZ
1426 case to_sv_amg:
1427 case to_av_amg:
1428 case to_hv_amg:
1429 case to_gv_amg:
1430 case to_cv_amg:
1431 /* FAIL safe */
b267980d 1432 return left; /* Delegate operation to standard mechanisms. */
f5284f61 1433 break;
a0d0e21e
LW
1434 default:
1435 goto not_found;
1436 }
1437 if (!cv) goto not_found;
1438 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1439 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
b267980d 1440 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 1441 ? (amtp = (AMT*)mg->mg_ptr)->table
8ac85365 1442 : (CV **) NULL))
a0d0e21e
LW
1443 && (cv = cvp[off=method])) { /* Method for right
1444 * argument found */
1445 lr=1;
b267980d
NIS
1446 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1447 && (cvp=ocvp) && (lr = -1))
a0d0e21e
LW
1448 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1449 && !(flags & AMGf_unary)) {
1450 /* We look for substitution for
1451 * comparison operations and
fc36a67e 1452 * concatenation */
a0d0e21e
LW
1453 if (method==concat_amg || method==concat_ass_amg
1454 || method==repeat_amg || method==repeat_ass_amg) {
1455 return NULL; /* Delegate operation to string conversion */
1456 }
1457 off = -1;
1458 switch (method) {
1459 case lt_amg:
1460 case le_amg:
1461 case gt_amg:
1462 case ge_amg:
1463 case eq_amg:
1464 case ne_amg:
1465 postpr = 1; off=ncmp_amg; break;
1466 case slt_amg:
1467 case sle_amg:
1468 case sgt_amg:
1469 case sge_amg:
1470 case seq_amg:
1471 case sne_amg:
1472 postpr = 1; off=scmp_amg; break;
1473 }
1474 if (off != -1) cv = cvp[off];
1475 if (!cv) {
1476 goto not_found;
1477 }
1478 } else {
a6006777 1479 not_found: /* No method found, either report or croak */
b267980d
NIS
1480 switch (method) {
1481 case to_sv_amg:
1482 case to_av_amg:
1483 case to_hv_amg:
1484 case to_gv_amg:
1485 case to_cv_amg:
1486 /* FAIL safe */
1487 return left; /* Delegate operation to standard mechanisms. */
1488 break;
1489 }
a0d0e21e
LW
1490 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1491 notfound = 1; lr = -1;
1492 } else if (cvp && (cv=cvp[nomethod_amg])) {
1493 notfound = 1; lr = 1;
1494 } else {
46fc3d4c 1495 SV *msg;
774d564b 1496 if (off==-1) off=method;
b267980d 1497 msg = sv_2mortal(Perl_newSVpvf(aTHX_
46fc3d4c 1498 "Operation `%s': no method found,%sargument %s%s%s%s",
22c35a8c 1499 PL_AMG_names[method + assignshift],
e7ea3e70 1500 (flags & AMGf_unary ? " " : "\n\tleft "),
b267980d 1501 SvAMAGIC(left)?
a0d0e21e
LW
1502 "in overloaded package ":
1503 "has no overloaded magic",
b267980d 1504 SvAMAGIC(left)?
a0d0e21e
LW
1505 HvNAME(SvSTASH(SvRV(left))):
1506 "",
b267980d 1507 SvAMAGIC(right)?
e7ea3e70 1508 ",\n\tright argument in overloaded package ":
b267980d 1509 (flags & AMGf_unary
e7ea3e70
IZ
1510 ? ""
1511 : ",\n\tright argument has no overloaded magic"),
b267980d 1512 SvAMAGIC(right)?
a0d0e21e 1513 HvNAME(SvSTASH(SvRV(right))):
46fc3d4c 1514 ""));
a0d0e21e 1515 if (amtp && amtp->fallback >= AMGfallYES) {
cea2e8a9 1516 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
a0d0e21e 1517 } else {
894356b3 1518 Perl_croak(aTHX_ "%"SVf, msg);
a0d0e21e
LW
1519 }
1520 return NULL;
1521 }
ee239bfe 1522 force_cpy = force_cpy || assign;
a0d0e21e
LW
1523 }
1524 }
1525 if (!notfound) {
b267980d 1526 DEBUG_o( Perl_deb(aTHX_
46fc3d4c 1527 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
22c35a8c 1528 PL_AMG_names[off],
748a9306
LW
1529 method+assignshift==off? "" :
1530 " (initially `",
1531 method+assignshift==off? "" :
22c35a8c 1532 PL_AMG_names[method+assignshift],
748a9306
LW
1533 method+assignshift==off? "" : "')",
1534 flags & AMGf_unary? "" :
1535 lr==1 ? " for right argument": " for left argument",
1536 flags & AMGf_unary? " for argument" : "",
b267980d 1537 HvNAME(stash),
a0d0e21e 1538 fl? ",\n\tassignment variant used": "") );
ee239bfe 1539 }
748a9306
LW
1540 /* Since we use shallow copy during assignment, we need
1541 * to dublicate the contents, probably calling user-supplied
1542 * version of copy operator
1543 */
ee239bfe
IZ
1544 /* We need to copy in following cases:
1545 * a) Assignment form was called.
1546 * assignshift==1, assign==T, method + 1 == off
1547 * b) Increment or decrement, called directly.
1548 * assignshift==0, assign==0, method + 0 == off
1549 * c) Increment or decrement, translated to assignment add/subtr.
b267980d 1550 * assignshift==0, assign==T,
ee239bfe
IZ
1551 * force_cpy == T
1552 * d) Increment or decrement, translated to nomethod.
b267980d 1553 * assignshift==0, assign==0,
ee239bfe
IZ
1554 * force_cpy == T
1555 * e) Assignment form translated to nomethod.
1556 * assignshift==1, assign==T, method + 1 != off
1557 * force_cpy == T
1558 */
1559 /* off is method, method+assignshift, or a result of opcode substitution.
1560 * In the latter case assignshift==0, so only notfound case is important.
1561 */
1562 if (( (method + assignshift == off)
1563 && (assign || (method == inc_amg) || (method == dec_amg)))
1564 || force_cpy)
1565 RvDEEPCP(left);
a0d0e21e
LW
1566 {
1567 dSP;
1568 BINOP myop;
1569 SV* res;
54310121 1570 bool oldcatch = CATCH_GET;
a0d0e21e 1571
54310121 1572 CATCH_SET(TRUE);
a0d0e21e
LW
1573 Zero(&myop, 1, BINOP);
1574 myop.op_last = (OP *) &myop;
1575 myop.op_next = Nullop;
54310121 1576 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
a0d0e21e 1577
e788e7d3 1578 PUSHSTACKi(PERLSI_OVERLOAD);
a0d0e21e 1579 ENTER;
462e5cf6 1580 SAVEOP();
533c011a 1581 PL_op = (OP *) &myop;
3280af22 1582 if (PERLDB_SUB && PL_curstash != PL_debstash)
533c011a 1583 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 1584 PUTBACK;
cea2e8a9 1585 pp_pushmark();
a0d0e21e 1586
924508f0 1587 EXTEND(SP, notfound + 5);
a0d0e21e
LW
1588 PUSHs(lr>0? right: left);
1589 PUSHs(lr>0? left: right);
3280af22 1590 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
a0d0e21e 1591 if (notfound) {
22c35a8c 1592 PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
a0d0e21e
LW
1593 }
1594 PUSHs((SV*)cv);
1595 PUTBACK;
1596
155aba94 1597 if ((PL_op = Perl_pp_entersub(aTHX)))
cea2e8a9 1598 CALLRUNOPS(aTHX);
a0d0e21e
LW
1599 LEAVE;
1600 SPAGAIN;
1601
1602 res=POPs;
ebafeae7 1603 PUTBACK;
d3acc0f7 1604 POPSTACK;
54310121 1605 CATCH_SET(oldcatch);
a0d0e21e 1606
a0d0e21e
LW
1607 if (postpr) {
1608 int ans;
1609 switch (method) {
1610 case le_amg:
1611 case sle_amg:
1612 ans=SvIV(res)<=0; break;
1613 case lt_amg:
1614 case slt_amg:
1615 ans=SvIV(res)<0; break;
1616 case ge_amg:
1617 case sge_amg:
1618 ans=SvIV(res)>=0; break;
1619 case gt_amg:
1620 case sgt_amg:
1621 ans=SvIV(res)>0; break;
1622 case eq_amg:
1623 case seq_amg:
1624 ans=SvIV(res)==0; break;
1625 case ne_amg:
1626 case sne_amg:
1627 ans=SvIV(res)!=0; break;
1628 case inc_amg:
1629 case dec_amg:
bbce6d69 1630 SvSetSV(left,res); return left;
dc437b57 1631 case not_amg:
fe7ac86a 1632 ans=!SvTRUE(res); break;
a0d0e21e 1633 }
54310121 1634 return boolSV(ans);
748a9306
LW
1635 } else if (method==copy_amg) {
1636 if (!SvROK(res)) {
cea2e8a9 1637 Perl_croak(aTHX_ "Copy method did not return a reference");
748a9306
LW
1638 }
1639 return SvREFCNT_inc(SvRV(res));
a0d0e21e
LW
1640 } else {
1641 return res;
1642 }
1643 }
1644}
c9d5ac95
GS
1645
1646/*
1647=for apidoc is_gv_magical
1648
1649Returns C<TRUE> if given the name of a magical GV.
1650
1651Currently only useful internally when determining if a GV should be
1652created even in rvalue contexts.
1653
1654C<flags> is not used at present but available for future extension to
1655allow selecting particular classes of magical variable.
1656
1657=cut
1658*/
1659bool
1660Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1661{
1662 if (!len)
1663 return FALSE;
1664
1665 switch (*name) {
1666 case 'I':
1667 if (len == 3 && strEQ(name, "ISA"))
1668 goto yes;
1669 break;
1670 case 'O':
1671 if (len == 8 && strEQ(name, "OVERLOAD"))
1672 goto yes;
1673 break;
1674 case 'S':
1675 if (len == 3 && strEQ(name, "SIG"))
1676 goto yes;
1677 break;
ac27b0f5
NIS
1678 case '\017': /* $^O & $^OPEN */
1679 if (len == 1
1680 || (len == 4 && strEQ(name, "\027PEN")))
1681 {
1682 goto yes;
1683 }
1684 break;
c9d5ac95
GS
1685 case '\027': /* $^W & $^WARNING_BITS */
1686 if (len == 1
1687 || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1688 || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1689 {
1690 goto yes;
1691 }
1692 break;
1693
1694 case '&':
1695 case '`':
1696 case '\'':
1697 case ':':
1698 case '?':
1699 case '!':
1700 case '-':
1701 case '#':
1702 case '*':
1703 case '[':
1704 case '^':
1705 case '~':
1706 case '=':
1707 case '%':
1708 case '.':
1709 case '(':
1710 case ')':
1711 case '<':
1712 case '>':
1713 case ',':
1714 case '\\':
1715 case '/':
1716 case '|':
1717 case '+':
1718 case ';':
1719 case ']':
1720 case '\001': /* $^A */
1721 case '\003': /* $^C */
1722 case '\004': /* $^D */
1723 case '\005': /* $^E */
1724 case '\006': /* $^F */
1725 case '\010': /* $^H */
1726 case '\011': /* $^I, NOT \t in EBCDIC */
1727 case '\014': /* $^L */
c9d5ac95
GS
1728 case '\020': /* $^P */
1729 case '\023': /* $^S */
1730 case '\024': /* $^T */
1731 case '\026': /* $^V */
1732 if (len == 1)
1733 goto yes;
1734 break;
1735 case '1':
1736 case '2':
1737 case '3':
1738 case '4':
1739 case '5':
1740 case '6':
1741 case '7':
1742 case '8':
1743 case '9':
1744 if (len > 1) {
1745 char *end = name + len;
1746 while (--end > name) {
1747 if (!isDIGIT(*end))
1748 return FALSE;
1749 }
1750 }
1751 yes:
1752 return TRUE;
1753 default:
1754 break;
1755 }
1756 return FALSE;
1757}