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