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