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