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