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