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