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