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