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