This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make lib/warnings.t use t/test.pl
[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
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 578Returns a pointer to the stash for a specified package. C<name> should
bc96cb06
SH
579be a valid UTF-8 string and must be null-terminated. If C<create> is set
580then the package will be created if it does not already exist. If C<create>
581is not set and the package 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
bc96cb06
SH
592/*
593=for apidoc gv_stashpvn
594
595Returns a pointer to the stash for a specified package. C<name> should
596be a valid UTF-8 string. The C<namelen> parameter indicates the length of
597the C<name>, in bytes. If C<create> is set then the package will be
598created if it does not already exist. If C<create> is not set and the
599package does not exist then NULL is returned.
600
601=cut
602*/
603
dc437b57 604HV*
864dbfa3 605Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
dc437b57 606{
46fc3d4c
PP
607 char smallbuf[256];
608 char *tmpbuf;
a0d0e21e
LW
609 HV *stash;
610 GV *tmpgv;
dc437b57 611
46fc3d4c
PP
612 if (namelen + 3 < sizeof smallbuf)
613 tmpbuf = smallbuf;
614 else
615 New(606, tmpbuf, namelen + 3, char);
dc437b57
PP
616 Copy(name,tmpbuf,namelen,char);
617 tmpbuf[namelen++] = ':';
618 tmpbuf[namelen++] = ':';
619 tmpbuf[namelen] = '\0';
46fc3d4c
PP
620 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
621 if (tmpbuf != smallbuf)
622 Safefree(tmpbuf);
a0d0e21e
LW
623 if (!tmpgv)
624 return 0;
625 if (!GvHV(tmpgv))
626 GvHV(tmpgv) = newHV();
627 stash = GvHV(tmpgv);
628 if (!HvNAME(stash))
629 HvNAME(stash) = savepv(name);
630 return stash;
463ee0b2
LW
631}
632
954c1994
GS
633/*
634=for apidoc gv_stashsv
635
386d01d6
GS
636Returns a pointer to the stash for a specified package, which must be a
637valid UTF-8 string. See C<gv_stashpv>.
954c1994
GS
638
639=cut
640*/
641
a0d0e21e 642HV*
864dbfa3 643Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
a0d0e21e 644{
dc437b57
PP
645 register char *ptr;
646 STRLEN len;
647 ptr = SvPV(sv,len);
648 return gv_stashpvn(ptr, len, create);
a0d0e21e
LW
649}
650
651
463ee0b2 652GV *
864dbfa3 653Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
79072805 654{
08105a92 655 register const char *name = nambeg;
463ee0b2 656 register GV *gv = 0;
79072805 657 GV**gvp;
79072805 658 I32 len;
08105a92 659 register const char *namend;
463ee0b2 660 HV *stash = 0;
79072805 661
c07a80fd
PP
662 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
663 name++;
664
79072805 665 for (namend = name; *namend; namend++) {
1d7c1841
GS
666 if ((*namend == ':' && namend[1] == ':')
667 || (*namend == '\'' && namend[1]))
463ee0b2 668 {
463ee0b2 669 if (!stash)
3280af22 670 stash = PL_defstash;
dc437b57 671 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
a0d0e21e 672 return Nullgv;
463ee0b2 673
85e6fe83
LW
674 len = namend - name;
675 if (len > 0) {
3c78fafa 676 char smallbuf[256];
62b57502 677 char *tmpbuf;
62b57502 678
25c09a70 679 if (len + 3 < sizeof (smallbuf))
3c78fafa 680 tmpbuf = smallbuf;
62b57502
MB
681 else
682 New(601, tmpbuf, len+3, char);
a0d0e21e
LW
683 Copy(name, tmpbuf, len, char);
684 tmpbuf[len++] = ':';
685 tmpbuf[len++] = ':';
686 tmpbuf[len] = '\0';
463ee0b2 687 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
6fa846a0 688 gv = gvp ? *gvp : Nullgv;
3280af22 689 if (gv && gv != (GV*)&PL_sv_undef) {
6fa846a0 690 if (SvTYPE(gv) != SVt_PVGV)
0f303493 691 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
6fa846a0
GS
692 else
693 GvMULTI_on(gv);
694 }
3c78fafa 695 if (tmpbuf != smallbuf)
62b57502 696 Safefree(tmpbuf);
3280af22 697 if (!gv || gv == (GV*)&PL_sv_undef)
a0d0e21e 698 return Nullgv;
85e6fe83 699
463ee0b2
LW
700 if (!(stash = GvHV(gv)))
701 stash = GvHV(gv) = newHV();
85e6fe83 702
463ee0b2 703 if (!HvNAME(stash))
a0d0e21e 704 HvNAME(stash) = savepvn(nambeg, namend - nambeg);
463ee0b2
LW
705 }
706
707 if (*namend == ':')
708 namend++;
709 namend++;
710 name = namend;
711 if (!*name)
3280af22 712 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
79072805 713 }
79072805 714 }
a0d0e21e 715 len = namend - name;
463ee0b2
LW
716
717 /* No stash in name, so see how we can default */
718
719 if (!stash) {
7e2040f0 720 if (isIDFIRST_lazy(name)) {
9607fc9c
PP
721 bool global = FALSE;
722
18ea00d7
NC
723 /* name is always \0 terminated, and initial \0 wouldn't return
724 true from isIDFIRST_lazy, so we know that name[1] is defined */
725 switch (name[1]) {
726 case '\0':
727 if (*name == '_')
9d116dd7 728 global = TRUE;
18ea00d7
NC
729 break;
730 case 'N':
731 if (strEQ(name, "INC") || strEQ(name, "ENV"))
9d116dd7 732 global = TRUE;
18ea00d7
NC
733 break;
734 case 'I':
735 if (strEQ(name, "SIG"))
9d116dd7 736 global = TRUE;
18ea00d7
NC
737 break;
738 case 'T':
739 if (strEQ(name, "STDIN") || strEQ(name, "STDOUT") ||
740 strEQ(name, "STDERR"))
463ee0b2 741 global = TRUE;
18ea00d7
NC
742 break;
743 case 'R':
744 if (strEQ(name, "ARGV") || strEQ(name, "ARGVOUT"))
745 global = TRUE;
746 break;
463ee0b2 747 }
9607fc9c 748
463ee0b2 749 if (global)
3280af22 750 stash = PL_defstash;
923e4eb5 751 else if (IN_PERL_COMPILETIME) {
3280af22
NIS
752 stash = PL_curstash;
753 if (add && (PL_hints & HINT_STRICT_VARS) &&
748a9306
LW
754 sv_type != SVt_PVCV &&
755 sv_type != SVt_PVGV &&
4633a7c4 756 sv_type != SVt_PVFM &&
c07a80fd 757 sv_type != SVt_PVIO &&
70ec6265
NC
758 !(len == 1 && sv_type == SVt_PV &&
759 (*name == 'a' || *name == 'b')) )
748a9306 760 {
4633a7c4
LW
761 gvp = (GV**)hv_fetch(stash,name,len,0);
762 if (!gvp ||
3280af22 763 *gvp == (GV*)&PL_sv_undef ||
a5f75d66
AD
764 SvTYPE(*gvp) != SVt_PVGV)
765 {
4633a7c4 766 stash = 0;
a5f75d66 767 }
155aba94
GS
768 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
769 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
770 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
4633a7c4 771 {
cea2e8a9 772 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
4633a7c4
LW
773 sv_type == SVt_PVAV ? '@' :
774 sv_type == SVt_PVHV ? '%' : '$',
775 name);
8ebc5c01 776 if (GvCVu(*gvp))
cc507455 777 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
a0d0e21e 778 stash = 0;
4633a7c4 779 }
a0d0e21e 780 }
85e6fe83 781 }
463ee0b2 782 else
1d7c1841 783 stash = CopSTASH(PL_curcop);
463ee0b2
LW
784 }
785 else
3280af22 786 stash = PL_defstash;
463ee0b2
LW
787 }
788
789 /* By this point we should have a stash and a name */
790
a0d0e21e 791 if (!stash) {
5a844595 792 if (add) {
608b3986 793 register SV *err = Perl_mess(aTHX_
5a844595
GS
794 "Global symbol \"%s%s\" requires explicit package name",
795 (sv_type == SVt_PV ? "$"
796 : sv_type == SVt_PVAV ? "@"
797 : sv_type == SVt_PVHV ? "%"
608b3986
AE
798 : ""), name);
799 if (USE_UTF8_IN_NAMES)
800 SvUTF8_on(err);
801 qerror(err);
d7aacf4e 802 stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
a0d0e21e 803 }
d7aacf4e
RGS
804 else
805 return Nullgv;
a0d0e21e
LW
806 }
807
808 if (!SvREFCNT(stash)) /* symbol table under destruction */
809 return Nullgv;
810
79072805 811 gvp = (GV**)hv_fetch(stash,name,len,add);
3280af22 812 if (!gvp || *gvp == (GV*)&PL_sv_undef)
79072805
LW
813 return Nullgv;
814 gv = *gvp;
815 if (SvTYPE(gv) == SVt_PVGV) {
a0d0e21e 816 if (add) {
a5f75d66 817 GvMULTI_on(gv);
a0d0e21e 818 gv_init_sv(gv, sv_type);
d2c93421
RH
819 if (*name=='!' && sv_type == SVt_PVHV && len==1)
820 require_errno(gv);
a0d0e21e 821 }
79072805 822 return gv;
55d729e4
GS
823 } else if (add & GV_NOINIT) {
824 return gv;
79072805 825 }
93a17b20
LW
826
827 /* Adding a new symbol */
828
0453d815 829 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
9014280d 830 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
55d729e4 831 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
a0d0e21e 832 gv_init_sv(gv, sv_type);
93a17b20 833
7272584d
PM
834 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
835 : (PL_dowarn & G_WARN_ON ) ) )
0453d815
PM
836 GvMULTI_on(gv) ;
837
93a17b20 838 /* set up magic where warranted */
cc4c2da6 839 if (len > 1) {
9431620d 840#ifndef EBCDIC
cc4c2da6
NC
841 if (*name > 'V' ) {
842 /* Nothing else to do.
91f565cb 843 The compiler will probably turn the switch statement into a
cc4c2da6
NC
844 branch table. Make sure we avoid even that small overhead for
845 the common case of lower case variable names. */
9431620d
NC
846 } else
847#endif
848 {
cc4c2da6
NC
849 const char *name2 = name + 1;
850 switch (*name) {
851 case 'A':
852 if (strEQ(name2, "RGV")) {
853 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
854 }
855 break;
856 case 'E':
857 if (strnEQ(name2, "XPORT", 5))
858 GvMULTI_on(gv);
859 break;
860 case 'I':
861 if (strEQ(name2, "SA")) {
862 AV* av = GvAVn(gv);
863 GvMULTI_on(gv);
864 sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
865 /* NOTE: No support for tied ISA */
866 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
867 && AvFILLp(av) == -1)
868 {
869 char *pname;
870 av_push(av, newSVpvn(pname = "NDBM_File",9));
871 gv_stashpvn(pname, 9, TRUE);
872 av_push(av, newSVpvn(pname = "DB_File",7));
873 gv_stashpvn(pname, 7, TRUE);
874 av_push(av, newSVpvn(pname = "GDBM_File",9));
875 gv_stashpvn(pname, 9, TRUE);
876 av_push(av, newSVpvn(pname = "SDBM_File",9));
877 gv_stashpvn(pname, 9, TRUE);
878 av_push(av, newSVpvn(pname = "ODBM_File",9));
879 gv_stashpvn(pname, 9, TRUE);
880 }
881 }
882 break;
883 case 'O':
884 if (strEQ(name2, "VERLOAD")) {
885 HV* hv = GvHVn(gv);
886 GvMULTI_on(gv);
887 hv_magic(hv, Nullgv, PERL_MAGIC_overload);
888 }
889 break;
890 case 'S':
891 if (strEQ(name2, "IG")) {
892 HV *hv;
893 I32 i;
894 if (!PL_psig_ptr) {
895 Newz(73, PL_psig_ptr, SIG_SIZE, SV*);
896 Newz(73, PL_psig_name, SIG_SIZE, SV*);
897 Newz(73, PL_psig_pend, SIG_SIZE, int);
898 }
899 GvMULTI_on(gv);
900 hv = GvHVn(gv);
901 hv_magic(hv, Nullgv, PERL_MAGIC_sig);
902 for (i = 1; i < SIG_SIZE; i++) {
903 SV ** init;
904 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
905 if (init)
906 sv_setsv(*init, &PL_sv_undef);
907 PL_psig_ptr[i] = 0;
908 PL_psig_name[i] = 0;
909 PL_psig_pend[i] = 0;
910 }
911 }
912 break;
913 case 'V':
914 if (strEQ(name2, "ERSION"))
915 GvMULTI_on(gv);
916 break;
917 case '\005': /* $^ENCODING */
918 if (strEQ(name2, "NCODING"))
919 goto magicalize;
920 break;
921 case '\017': /* $^OPEN */
922 if (strEQ(name2, "PEN"))
923 goto magicalize;
924 break;
925 case '\024': /* ${^TAINT} */
926 if (strEQ(name2, "AINT"))
927 goto ro_magicalize;
928 break;
7cebcbc0 929 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
cc4c2da6
NC
930 if (strEQ(name2, "NICODE"))
931 goto ro_magicalize;
7cebcbc0
NC
932 if (strEQ(name2, "TF8LOCALE"))
933 goto ro_magicalize;
cc4c2da6
NC
934 break;
935 case '\027': /* $^WARNING_BITS */
936 if (strEQ(name2, "ARNING_BITS"))
937 goto magicalize;
938 break;
939 case '1':
940 case '2':
941 case '3':
942 case '4':
943 case '5':
944 case '6':
945 case '7':
946 case '8':
947 case '9':
85e6fe83 948 {
cc4c2da6
NC
949 /* ensures variable is only digits */
950 /* ${"1foo"} fails this test (and is thus writeable) */
951 /* added by japhy, but borrowed from is_gv_magical */
952 const char *end = name + len;
953 while (--end > name) {
954 if (!isDIGIT(*end)) return gv;
955 }
956 goto ro_magicalize;
1d7c1841 957 }
dc437b57 958 }
93a17b20 959 }
392db708
NC
960 } else {
961 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
962 be case '\0' in this switch statement (ie a default case) */
cc4c2da6
NC
963 switch (*name) {
964 case '&':
965 case '`':
966 case '\'':
967 if (
968 sv_type == SVt_PVAV ||
969 sv_type == SVt_PVHV ||
970 sv_type == SVt_PVCV ||
971 sv_type == SVt_PVFM ||
972 sv_type == SVt_PVIO
973 ) { break; }
974 PL_sawampersand = TRUE;
975 goto ro_magicalize;
976
977 case ':':
978 sv_setpv(GvSV(gv),PL_chopset);
979 goto magicalize;
980
981 case '?':
ff0cee69 982#ifdef COMPLEX_STATUS
cc4c2da6 983 (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
ff0cee69 984#endif
cc4c2da6 985 goto magicalize;
ff0cee69 986
cc4c2da6 987 case '!':
d2c93421 988
cc4c2da6
NC
989 /* If %! has been used, automatically load Errno.pm.
990 The require will itself set errno, so in order to
991 preserve its value we have to set up the magic
992 now (rather than going to magicalize)
993 */
d2c93421 994
cc4c2da6 995 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
d2c93421 996
cc4c2da6
NC
997 if (sv_type == SVt_PVHV)
998 require_errno(gv);
d2c93421 999
6cef1e77 1000 break;
cc4c2da6
NC
1001 case '-':
1002 {
6cef1e77 1003 AV* av = GvAVn(gv);
14befaf4 1004 sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
03a27ae7 1005 SvREADONLY_on(av);
cc4c2da6
NC
1006 goto magicalize;
1007 }
1008 case '*':
1009 if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1010 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1011 "$* is no longer supported");
6cef1e77 1012 break;
cc4c2da6
NC
1013 case '#':
1014 if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1015 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1016 "Use of $# is deprecated");
1017 goto magicalize;
1018 case '|':
1019 sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1020 goto magicalize;
1021
1022 case '+':
1023 {
1024 AV* av = GvAVn(gv);
14befaf4 1025 sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
03a27ae7 1026 SvREADONLY_on(av);
cc4c2da6 1027 /* FALL THROUGH */
e521374c 1028 }
cc4c2da6
NC
1029 case '\023': /* $^S */
1030 case '1':
1031 case '2':
1032 case '3':
1033 case '4':
1034 case '5':
1035 case '6':
1036 case '7':
1037 case '8':
1038 case '9':
1039 ro_magicalize:
1040 SvREADONLY_on(GvSV(gv));
1041 /* FALL THROUGH */
1042 case '[':
1043 case '^':
1044 case '~':
1045 case '=':
1046 case '%':
1047 case '.':
1048 case '(':
1049 case ')':
1050 case '<':
1051 case '>':
1052 case ',':
1053 case '\\':
1054 case '/':
1055 case '\001': /* $^A */
1056 case '\003': /* $^C */
1057 case '\004': /* $^D */
1058 case '\005': /* $^E */
1059 case '\006': /* $^F */
1060 case '\010': /* $^H */
1061 case '\011': /* $^I, NOT \t in EBCDIC */
1062 case '\016': /* $^N */
1063 case '\017': /* $^O */
1064 case '\020': /* $^P */
1065 case '\024': /* $^T */
1066 case '\027': /* $^W */
1067 magicalize:
1068 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1069 break;
e521374c 1070
cc4c2da6
NC
1071 case '\014': /* $^L */
1072 sv_setpv(GvSV(gv),"\f");
1073 PL_formfeed = GvSV(gv);
463ee0b2 1074 break;
cc4c2da6
NC
1075 case ';':
1076 sv_setpv(GvSV(gv),"\034");
463ee0b2 1077 break;
cc4c2da6
NC
1078 case ']':
1079 {
f86702cc 1080 SV *sv = GvSV(gv);
d7aa5382
JP
1081 if (!sv_derived_from(PL_patchlevel, "version"))
1082 (void *)upg_version(PL_patchlevel);
7d54d38e
SH
1083 GvSV(gv) = vnumify(PL_patchlevel);
1084 SvREADONLY_on(GvSV(gv));
1085 SvREFCNT_dec(sv);
93a17b20
LW
1086 }
1087 break;
cc4c2da6
NC
1088 case '\026': /* $^V */
1089 {
16070b82 1090 SV *sv = GvSV(gv);
f9be5ac8
DM
1091 GvSV(gv) = new_version(PL_patchlevel);
1092 SvREADONLY_on(GvSV(gv));
1093 SvREFCNT_dec(sv);
16070b82
GS
1094 }
1095 break;
cc4c2da6 1096 }
79072805 1097 }
93a17b20 1098 return gv;
79072805
LW
1099}
1100
1101void
43693395
GS
1102Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1103{
e27ad1f2 1104 char *name;
43693395
GS
1105 HV *hv = GvSTASH(gv);
1106 if (!hv) {
0c34ef67 1107 SvOK_off(sv);
43693395
GS
1108 return;
1109 }
1110 sv_setpv(sv, prefix ? prefix : "");
e27ad1f2 1111
9dde0ab5
NC
1112 name = HvNAME(hv);
1113 if (!name)
e27ad1f2 1114 name = "__ANON__";
9dde0ab5 1115
e27ad1f2 1116 if (keepmain || strNE(name, "main")) {
6a7a3232
NC
1117 sv_catpv(sv,name);
1118 sv_catpvn(sv,"::", 2);
43693395 1119 }
257984c0 1120 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
43693395
GS
1121}
1122
1123void
864dbfa3 1124Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
79072805 1125{
84e79d79 1126 gv_fullname4(sv, gv, prefix, TRUE);
79072805
LW
1127}
1128
1129void
43693395
GS
1130Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1131{
1132 GV *egv = GvEGV(gv);
1133 if (!egv)
1134 egv = gv;
1135 gv_fullname4(sv, egv, prefix, keepmain);
1136}
1137
1138void
864dbfa3 1139Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
79072805 1140{
84e79d79 1141 gv_efullname4(sv, gv, prefix, TRUE);
f6aff53a
PP
1142}
1143
1144/* XXX compatibility with versions <= 5.003. */
1145void
864dbfa3 1146Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
f6aff53a
PP
1147{
1148 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1149}
1150
1151/* XXX compatibility with versions <= 5.003. */
1152void
864dbfa3 1153Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
f6aff53a
PP
1154{
1155 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
79072805
LW
1156}
1157
1158IO *
864dbfa3 1159Perl_newIO(pTHX)
79072805
LW
1160{
1161 IO *io;
8990e307
LW
1162 GV *iogv;
1163
1164 io = (IO*)NEWSV(0,0);
a0d0e21e 1165 sv_upgrade((SV *)io,SVt_PVIO);
8990e307
LW
1166 SvREFCNT(io) = 1;
1167 SvOBJECT_on(io);
081fc587
AB
1168 /* Clear the stashcache because a new IO could overrule a
1169 package name */
1170 hv_clear(PL_stashcache);
c9de509e 1171 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
5f2d631d
GS
1172 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1173 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
c9de509e 1174 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
8990e307 1175 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
79072805
LW
1176 return io;
1177}
1178
1179void
864dbfa3 1180Perl_gv_check(pTHX_ HV *stash)
79072805
LW
1181{
1182 register HE *entry;
1183 register I32 i;
1184 register GV *gv;
463ee0b2
LW
1185 HV *hv;
1186
8990e307
LW
1187 if (!HvARRAY(stash))
1188 return;
a0d0e21e 1189 for (i = 0; i <= (I32) HvMAX(stash); i++) {
dc437b57
PP
1190 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1191 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
b862623f 1192 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
a0d0e21e 1193 {
19b6c847 1194 if (hv != PL_defstash && hv != stash)
a0d0e21e
LW
1195 gv_check(hv); /* nested package */
1196 }
dc437b57 1197 else if (isALPHA(*HeKEY(entry))) {
1d7c1841 1198 char *file;
dc437b57 1199 gv = (GV*)HeVAL(entry);
55d729e4 1200 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
463ee0b2 1201 continue;
1d7c1841
GS
1202 file = GvFILE(gv);
1203 /* performance hack: if filename is absolute and it's a standard
1204 * module, don't bother warning */
1205 if (file
1206 && PERL_FILE_IS_ABSOLUTE(file)
6eb630b7
CN
1207#ifdef MACOS_TRADITIONAL
1208 && (instr(file, ":lib:")
1209#else
1210 && (instr(file, "/lib/")
1211#endif
1212 || instr(file, ".pm")))
1d7c1841 1213 {
8990e307 1214 continue;
1d7c1841
GS
1215 }
1216 CopLINE_set(PL_curcop, GvLINE(gv));
1217#ifdef USE_ITHREADS
1218 CopFILE(PL_curcop) = file; /* set for warning */
1219#else
1220 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1221#endif
9014280d 1222 Perl_warner(aTHX_ packWARN(WARN_ONCE),
599cee73 1223 "Name \"%s::%s\" used only once: possible typo",
a0d0e21e 1224 HvNAME(stash), GvNAME(gv));
463ee0b2 1225 }
79072805
LW
1226 }
1227 }
1228}
1229
1230GV *
864dbfa3 1231Perl_newGVgen(pTHX_ char *pack)
79072805 1232{
cea2e8a9 1233 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
46fc3d4c 1234 TRUE, SVt_PVGV);
79072805
LW
1235}
1236
1237/* hopefully this is only called on local symbol table entries */
1238
1239GP*
864dbfa3 1240Perl_gp_ref(pTHX_ GP *gp)
79072805 1241{
1d7c1841
GS
1242 if (!gp)
1243 return (GP*)NULL;
79072805 1244 gp->gp_refcnt++;
44a8e56a
PP
1245 if (gp->gp_cv) {
1246 if (gp->gp_cvgen) {
1247 /* multi-named GPs cannot be used for method cache */
1248 SvREFCNT_dec(gp->gp_cv);
1249 gp->gp_cv = Nullcv;
1250 gp->gp_cvgen = 0;
1251 }
1252 else {
1253 /* Adding a new name to a subroutine invalidates method cache */
3280af22 1254 PL_sub_generation++;
44a8e56a
PP
1255 }
1256 }
79072805 1257 return gp;
79072805
LW
1258}
1259
1260void
864dbfa3 1261Perl_gp_free(pTHX_ GV *gv)
79072805 1262{
79072805
LW
1263 GP* gp;
1264
1265 if (!gv || !(gp = GvGP(gv)))
1266 return;
f248d071
GS
1267 if (gp->gp_refcnt == 0) {
1268 if (ckWARN_d(WARN_INTERNAL))
9014280d 1269 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
472d47bc
SB
1270 "Attempt to free unreferenced glob pointers"
1271 pTHX__FORMAT pTHX__VALUE);
79072805
LW
1272 return;
1273 }
44a8e56a
PP
1274 if (gp->gp_cv) {
1275 /* Deleting the name of a subroutine invalidates method cache */
3280af22 1276 PL_sub_generation++;
44a8e56a 1277 }
748a9306
LW
1278 if (--gp->gp_refcnt > 0) {
1279 if (gp->gp_egv == gv)
1280 gp->gp_egv = 0;
79072805 1281 return;
748a9306 1282 }
79072805 1283
13207a71 1284 if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
8926f269 1285 if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
13207a71
JH
1286 if (gp->gp_hv) {
1287 if (PL_stashcache && HvNAME(gp->gp_hv))
1288 hv_delete(PL_stashcache,
1289 HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)),
1290 G_DISCARD);
1291 SvREFCNT_dec(gp->gp_hv);
1292 }
1293 if (gp->gp_io) SvREFCNT_dec(gp->gp_io);
1294 if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv);
1295 if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
748a9306 1296
79072805
LW
1297 Safefree(gp);
1298 GvGP(gv) = 0;
1299}
1300
d460ef45
NIS
1301int
1302Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1303{
1304 AMT *amtp = (AMT*)mg->mg_ptr;
1305 if (amtp && AMT_AMAGIC(amtp)) {
1306 int i;
1307 for (i = 1; i < NofAMmeth; i++) {
1308 CV *cv = amtp->table[i];
1309 if (cv != Nullcv) {
1310 SvREFCNT_dec((SV *) cv);
1311 amtp->table[i] = Nullcv;
1312 }
1313 }
1314 }
1315 return 0;
1316}
1317
a0d0e21e
LW
1318/* Updates and caches the CV's */
1319
1320bool
864dbfa3 1321Perl_Gv_AMupdate(pTHX_ HV *stash)
a0d0e21e 1322{
a0d0e21e
LW
1323 GV* gv;
1324 CV* cv;
14befaf4 1325 MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
8ac85365 1326 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
a6006777 1327 AMT amt;
a0d0e21e 1328
3280af22
NIS
1329 if (mg && amtp->was_ok_am == PL_amagic_generation
1330 && amtp->was_ok_sub == PL_sub_generation)
eb160463 1331 return (bool)AMT_OVERLOADED(amtp);
14befaf4 1332 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
a0d0e21e 1333
cea2e8a9 1334 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
a0d0e21e 1335
d460ef45 1336 Zero(&amt,1,AMT);
3280af22
NIS
1337 amt.was_ok_am = PL_amagic_generation;
1338 amt.was_ok_sub = PL_sub_generation;
a6006777
PP
1339 amt.fallback = AMGfallNO;
1340 amt.flags = 0;
1341
a6006777 1342 {
32251b26
IZ
1343 int filled = 0, have_ovl = 0;
1344 int i, lim = 1;
a6006777 1345 SV* sv = NULL;
a6006777 1346
22c35a8c 1347 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
a6006777 1348
89ffc314
IZ
1349 /* Try to find via inheritance. */
1350 gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1351 if (gv)
1352 sv = GvSV(gv);
1353
1354 if (!gv)
32251b26 1355 lim = DESTROY_amg; /* Skip overloading entries. */
89ffc314
IZ
1356 else if (SvTRUE(sv))
1357 amt.fallback=AMGfallYES;
1358 else if (SvOK(sv))
1359 amt.fallback=AMGfallNEVER;
a6006777 1360
32251b26
IZ
1361 for (i = 1; i < lim; i++)
1362 amt.table[i] = Nullcv;
1363 for (; i < NofAMmeth; i++) {
c8ce92fc 1364 char *cooky = (char*)PL_AMG_names[i];
32251b26
IZ
1365 /* Human-readable form, for debugging: */
1366 char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
89ffc314
IZ
1367 STRLEN l = strlen(cooky);
1368
cea2e8a9 1369 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
44a8e56a 1370 cp, HvNAME(stash)) );
611c1e95
IZ
1371 /* don't fill the cache while looking up!
1372 Creation of inheritance stubs in intermediate packages may
1373 conflict with the logic of runtime method substitution.
1374 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1375 then we could have created stubs for "(+0" in A and C too.
1376 But if B overloads "bool", we may want to use it for
1377 numifying instead of C's "+0". */
1378 if (i >= DESTROY_amg)
1379 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1380 else /* Autoload taken care of below */
1381 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
46fc3d4c 1382 cv = 0;
89ffc314 1383 if (gv && (cv = GvCV(gv))) {
44a8e56a
PP
1384 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1385 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
611c1e95
IZ
1386 /* This is a hack to support autoloading..., while
1387 knowing *which* methods were declared as overloaded. */
44a8e56a 1388 /* GvSV contains the name of the method. */
4ea42e7f 1389 GV *ngv = Nullgv;
44a8e56a 1390
84c133a0
RB
1391 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%"SVf256\
1392 "' for overloaded `%s' in package `%.256s'\n",
35c1215d 1393 GvSV(gv), cp, HvNAME(stash)) );
b267980d 1394 if (!SvPOK(GvSV(gv))
dc848c6f
PP
1395 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1396 FALSE)))
1397 {
44a8e56a 1398 /* Can be an import stub (created by `can'). */
35c1215d
NC
1399 SV *gvsv = GvSV(gv);
1400 const char *name = SvPOK(gvsv) ? SvPVX(gvsv) : "???";
84c133a0
RB
1401 Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' "\
1402 "in package `%.256s'",
35c1215d
NC
1403 (GvCVGEN(gv) ? "Stub found while resolving"
1404 : "Can't resolve"),
1405 name, cp, HvNAME(stash));
44a8e56a 1406 }
dc848c6f 1407 cv = GvCV(gv = ngv);
44a8e56a 1408 }
cea2e8a9 1409 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
44a8e56a
PP
1410 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1411 GvNAME(CvGV(cv))) );
1412 filled = 1;
32251b26
IZ
1413 if (i < DESTROY_amg)
1414 have_ovl = 1;
611c1e95
IZ
1415 } else if (gv) { /* Autoloaded... */
1416 cv = (CV*)gv;
1417 filled = 1;
44a8e56a 1418 }
a6006777 1419 amt.table[i]=(CV*)SvREFCNT_inc(cv);
a0d0e21e 1420 }
a0d0e21e 1421 if (filled) {
a6006777 1422 AMT_AMAGIC_on(&amt);
32251b26
IZ
1423 if (have_ovl)
1424 AMT_OVERLOADED_on(&amt);
14befaf4
DM
1425 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1426 (char*)&amt, sizeof(AMT));
32251b26 1427 return have_ovl;
a0d0e21e
LW
1428 }
1429 }
a6006777 1430 /* Here we have no table: */
9cbac4c7 1431 /* no_table: */
a6006777 1432 AMT_AMAGIC_off(&amt);
14befaf4
DM
1433 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1434 (char*)&amt, sizeof(AMTS));
a0d0e21e
LW
1435 return FALSE;
1436}
1437
32251b26
IZ
1438
1439CV*
1440Perl_gv_handler(pTHX_ HV *stash, I32 id)
1441{
3f8f4626 1442 MAGIC *mg;
32251b26 1443 AMT *amtp;
3ad83ce7 1444 CV *ret;
32251b26 1445
e27ad1f2 1446 if (!stash || !HvNAME(stash))
3f8f4626 1447 return Nullcv;
14befaf4 1448 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
32251b26
IZ
1449 if (!mg) {
1450 do_update:
1451 Gv_AMupdate(stash);
14befaf4 1452 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
32251b26
IZ
1453 }
1454 amtp = (AMT*)mg->mg_ptr;
1455 if ( amtp->was_ok_am != PL_amagic_generation
1456 || amtp->was_ok_sub != PL_sub_generation )
1457 goto do_update;
3ad83ce7
AMS
1458 if (AMT_AMAGIC(amtp)) {
1459 ret = amtp->table[id];
1460 if (ret && isGV(ret)) { /* Autoloading stab */
1461 /* Passing it through may have resulted in a warning
1462 "Inherited AUTOLOAD for a non-method deprecated", since
1463 our caller is going through a function call, not a method call.
1464 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1465 GV *gv = gv_fetchmethod(stash, (char*)PL_AMG_names[id]);
1466
1467 if (gv && GvCV(gv))
1468 return GvCV(gv);
1469 }
1470 return ret;
1471 }
1472
32251b26
IZ
1473 return Nullcv;
1474}
1475
1476
a0d0e21e 1477SV*
864dbfa3 1478Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
a0d0e21e 1479{
b267980d 1480 MAGIC *mg;
9c5ffd7c 1481 CV *cv=NULL;
a0d0e21e 1482 CV **cvp=NULL, **ocvp=NULL;
9c5ffd7c 1483 AMT *amtp=NULL, *oamtp=NULL;
497b47a8 1484 int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
ee239bfe 1485 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
497b47a8
JH
1486#ifdef DEBUGGING
1487 int fl=0;
497b47a8 1488#endif
25716404 1489 HV* stash=NULL;
a0d0e21e 1490 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
25716404
GS
1491 && (stash = SvSTASH(SvRV(left)))
1492 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
b267980d 1493 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 1494 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
8ac85365 1495 : (CV **) NULL))
b267980d 1496 && ((cv = cvp[off=method+assignshift])
748a9306
LW
1497 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1498 * usual method */
497b47a8
JH
1499 (
1500#ifdef DEBUGGING
1501 fl = 1,
1502#endif
1503 cv = cvp[off=method])))) {
a0d0e21e
LW
1504 lr = -1; /* Call method for left argument */
1505 } else {
1506 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1507 int logic;
1508
1509 /* look for substituted methods */
ee239bfe 1510 /* In all the covered cases we should be called with assign==0. */
a0d0e21e
LW
1511 switch (method) {
1512 case inc_amg:
ee239bfe
IZ
1513 force_cpy = 1;
1514 if ((cv = cvp[off=add_ass_amg])
1515 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3280af22 1516 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1517 }
1518 break;
1519 case dec_amg:
ee239bfe
IZ
1520 force_cpy = 1;
1521 if ((cv = cvp[off = subtr_ass_amg])
1522 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3280af22 1523 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1524 }
1525 break;
1526 case bool__amg:
1527 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1528 break;
1529 case numer_amg:
1530 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1531 break;
1532 case string_amg:
1533 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1534 break;
dc437b57 1535 case not_amg:
b267980d 1536 (void)((cv = cvp[off=bool__amg])
dc437b57
PP
1537 || (cv = cvp[off=numer_amg])
1538 || (cv = cvp[off=string_amg]));
1539 postpr = 1;
1540 break;
748a9306
LW
1541 case copy_amg:
1542 {
76e3520e
GS
1543 /*
1544 * SV* ref causes confusion with the interpreter variable of
1545 * the same name
1546 */
1547 SV* tmpRef=SvRV(left);
1548 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
fc36a67e
PP
1549 /*
1550 * Just to be extra cautious. Maybe in some
1551 * additional cases sv_setsv is safe, too.
1552 */
76e3520e 1553 SV* newref = newSVsv(tmpRef);
748a9306 1554 SvOBJECT_on(newref);
76e3520e 1555 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
748a9306
LW
1556 return newref;
1557 }
1558 }
1559 break;
a0d0e21e 1560 case abs_amg:
b267980d 1561 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
a0d0e21e 1562 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
748a9306 1563 SV* nullsv=sv_2mortal(newSViv(0));
a0d0e21e 1564 if (off1==lt_amg) {
748a9306 1565 SV* lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1566 lt_amg,AMGf_noright);
1567 logic = SvTRUE(lessp);
1568 } else {
748a9306 1569 SV* lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1570 ncmp_amg,AMGf_noright);
1571 logic = (SvNV(lessp) < 0);
1572 }
1573 if (logic) {
1574 if (off==subtr_amg) {
1575 right = left;
748a9306 1576 left = nullsv;
a0d0e21e
LW
1577 lr = 1;
1578 }
1579 } else {
1580 return left;
1581 }
1582 }
1583 break;
1584 case neg_amg:
155aba94 1585 if ((cv = cvp[off=subtr_amg])) {
a0d0e21e
LW
1586 right = left;
1587 left = sv_2mortal(newSViv(0));
1588 lr = 1;
1589 }
1590 break;
f216259d 1591 case int_amg:
f5284f61 1592 case iter_amg: /* XXXX Eventually should do to_gv. */
b267980d
NIS
1593 /* FAIL safe */
1594 return NULL; /* Delegate operation to standard mechanisms. */
1595 break;
f5284f61
IZ
1596 case to_sv_amg:
1597 case to_av_amg:
1598 case to_hv_amg:
1599 case to_gv_amg:
1600 case to_cv_amg:
1601 /* FAIL safe */
b267980d 1602 return left; /* Delegate operation to standard mechanisms. */
f5284f61 1603 break;
a0d0e21e
LW
1604 default:
1605 goto not_found;
1606 }
1607 if (!cv) goto not_found;
1608 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
25716404
GS
1609 && (stash = SvSTASH(SvRV(right)))
1610 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
b267980d 1611 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 1612 ? (amtp = (AMT*)mg->mg_ptr)->table
8ac85365 1613 : (CV **) NULL))
a0d0e21e
LW
1614 && (cv = cvp[off=method])) { /* Method for right
1615 * argument found */
1616 lr=1;
b267980d
NIS
1617 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1618 && (cvp=ocvp) && (lr = -1))
a0d0e21e
LW
1619 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1620 && !(flags & AMGf_unary)) {
1621 /* We look for substitution for
1622 * comparison operations and
fc36a67e 1623 * concatenation */
a0d0e21e
LW
1624 if (method==concat_amg || method==concat_ass_amg
1625 || method==repeat_amg || method==repeat_ass_amg) {
1626 return NULL; /* Delegate operation to string conversion */
1627 }
1628 off = -1;
1629 switch (method) {
1630 case lt_amg:
1631 case le_amg:
1632 case gt_amg:
1633 case ge_amg:
1634 case eq_amg:
1635 case ne_amg:
1636 postpr = 1; off=ncmp_amg; break;
1637 case slt_amg:
1638 case sle_amg:
1639 case sgt_amg:
1640 case sge_amg:
1641 case seq_amg:
1642 case sne_amg:
1643 postpr = 1; off=scmp_amg; break;
1644 }
1645 if (off != -1) cv = cvp[off];
1646 if (!cv) {
1647 goto not_found;
1648 }
1649 } else {
a6006777 1650 not_found: /* No method found, either report or croak */
b267980d
NIS
1651 switch (method) {
1652 case to_sv_amg:
1653 case to_av_amg:
1654 case to_hv_amg:
1655 case to_gv_amg:
1656 case to_cv_amg:
1657 /* FAIL safe */
1658 return left; /* Delegate operation to standard mechanisms. */
1659 break;
1660 }
a0d0e21e
LW
1661 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1662 notfound = 1; lr = -1;
1663 } else if (cvp && (cv=cvp[nomethod_amg])) {
1664 notfound = 1; lr = 1;
1665 } else {
46fc3d4c 1666 SV *msg;
774d564b 1667 if (off==-1) off=method;
b267980d 1668 msg = sv_2mortal(Perl_newSVpvf(aTHX_
46fc3d4c 1669 "Operation `%s': no method found,%sargument %s%s%s%s",
89ffc314 1670 AMG_id2name(method + assignshift),
e7ea3e70 1671 (flags & AMGf_unary ? " " : "\n\tleft "),
b267980d 1672 SvAMAGIC(left)?
a0d0e21e
LW
1673 "in overloaded package ":
1674 "has no overloaded magic",
b267980d 1675 SvAMAGIC(left)?
a0d0e21e
LW
1676 HvNAME(SvSTASH(SvRV(left))):
1677 "",
b267980d 1678 SvAMAGIC(right)?
e7ea3e70 1679 ",\n\tright argument in overloaded package ":
b267980d 1680 (flags & AMGf_unary
e7ea3e70
IZ
1681 ? ""
1682 : ",\n\tright argument has no overloaded magic"),
b267980d 1683 SvAMAGIC(right)?
a0d0e21e 1684 HvNAME(SvSTASH(SvRV(right))):
46fc3d4c 1685 ""));
a0d0e21e 1686 if (amtp && amtp->fallback >= AMGfallYES) {
cea2e8a9 1687 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
a0d0e21e 1688 } else {
894356b3 1689 Perl_croak(aTHX_ "%"SVf, msg);
a0d0e21e
LW
1690 }
1691 return NULL;
1692 }
ee239bfe 1693 force_cpy = force_cpy || assign;
a0d0e21e
LW
1694 }
1695 }
497b47a8 1696#ifdef DEBUGGING
a0d0e21e 1697 if (!notfound) {
497b47a8
JH
1698 DEBUG_o(Perl_deb(aTHX_
1699 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1700 AMG_id2name(off),
1701 method+assignshift==off? "" :
1702 " (initially `",
1703 method+assignshift==off? "" :
1704 AMG_id2name(method+assignshift),
1705 method+assignshift==off? "" : "')",
1706 flags & AMGf_unary? "" :
1707 lr==1 ? " for right argument": " for left argument",
1708 flags & AMGf_unary? " for argument" : "",
25716404 1709 stash ? HvNAME(stash) : "null",
497b47a8 1710 fl? ",\n\tassignment variant used": "") );
ee239bfe 1711 }
497b47a8 1712#endif
748a9306
LW
1713 /* Since we use shallow copy during assignment, we need
1714 * to dublicate the contents, probably calling user-supplied
1715 * version of copy operator
1716 */
ee239bfe
IZ
1717 /* We need to copy in following cases:
1718 * a) Assignment form was called.
1719 * assignshift==1, assign==T, method + 1 == off
1720 * b) Increment or decrement, called directly.
1721 * assignshift==0, assign==0, method + 0 == off
1722 * c) Increment or decrement, translated to assignment add/subtr.
b267980d 1723 * assignshift==0, assign==T,
ee239bfe
IZ
1724 * force_cpy == T
1725 * d) Increment or decrement, translated to nomethod.
b267980d 1726 * assignshift==0, assign==0,
ee239bfe
IZ
1727 * force_cpy == T
1728 * e) Assignment form translated to nomethod.
1729 * assignshift==1, assign==T, method + 1 != off
1730 * force_cpy == T
1731 */
1732 /* off is method, method+assignshift, or a result of opcode substitution.
1733 * In the latter case assignshift==0, so only notfound case is important.
1734 */
1735 if (( (method + assignshift == off)
1736 && (assign || (method == inc_amg) || (method == dec_amg)))
1737 || force_cpy)
1738 RvDEEPCP(left);
a0d0e21e
LW
1739 {
1740 dSP;
1741 BINOP myop;
1742 SV* res;
54310121 1743 bool oldcatch = CATCH_GET;
a0d0e21e 1744
54310121 1745 CATCH_SET(TRUE);
a0d0e21e
LW
1746 Zero(&myop, 1, BINOP);
1747 myop.op_last = (OP *) &myop;
1748 myop.op_next = Nullop;
54310121 1749 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
a0d0e21e 1750
e788e7d3 1751 PUSHSTACKi(PERLSI_OVERLOAD);
a0d0e21e 1752 ENTER;
462e5cf6 1753 SAVEOP();
533c011a 1754 PL_op = (OP *) &myop;
3280af22 1755 if (PERLDB_SUB && PL_curstash != PL_debstash)
533c011a 1756 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 1757 PUTBACK;
cea2e8a9 1758 pp_pushmark();
a0d0e21e 1759
924508f0 1760 EXTEND(SP, notfound + 5);
a0d0e21e
LW
1761 PUSHs(lr>0? right: left);
1762 PUSHs(lr>0? left: right);
3280af22 1763 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
a0d0e21e 1764 if (notfound) {
89ffc314 1765 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
a0d0e21e
LW
1766 }
1767 PUSHs((SV*)cv);
1768 PUTBACK;
1769
155aba94 1770 if ((PL_op = Perl_pp_entersub(aTHX)))
cea2e8a9 1771 CALLRUNOPS(aTHX);
a0d0e21e
LW
1772 LEAVE;
1773 SPAGAIN;
1774
1775 res=POPs;
ebafeae7 1776 PUTBACK;
d3acc0f7 1777 POPSTACK;
54310121 1778 CATCH_SET(oldcatch);
a0d0e21e 1779
a0d0e21e 1780 if (postpr) {
9c5ffd7c 1781 int ans=0;
a0d0e21e
LW
1782 switch (method) {
1783 case le_amg:
1784 case sle_amg:
1785 ans=SvIV(res)<=0; break;
1786 case lt_amg:
1787 case slt_amg:
1788 ans=SvIV(res)<0; break;
1789 case ge_amg:
1790 case sge_amg:
1791 ans=SvIV(res)>=0; break;
1792 case gt_amg:
1793 case sgt_amg:
1794 ans=SvIV(res)>0; break;
1795 case eq_amg:
1796 case seq_amg:
1797 ans=SvIV(res)==0; break;
1798 case ne_amg:
1799 case sne_amg:
1800 ans=SvIV(res)!=0; break;
1801 case inc_amg:
1802 case dec_amg:
bbce6d69 1803 SvSetSV(left,res); return left;
dc437b57 1804 case not_amg:
fe7ac86a 1805 ans=!SvTRUE(res); break;
a0d0e21e 1806 }
54310121 1807 return boolSV(ans);
748a9306
LW
1808 } else if (method==copy_amg) {
1809 if (!SvROK(res)) {
cea2e8a9 1810 Perl_croak(aTHX_ "Copy method did not return a reference");
748a9306
LW
1811 }
1812 return SvREFCNT_inc(SvRV(res));
a0d0e21e
LW
1813 } else {
1814 return res;
1815 }
1816 }
1817}
c9d5ac95
GS
1818
1819/*
1820=for apidoc is_gv_magical
1821
1822Returns C<TRUE> if given the name of a magical GV.
1823
1824Currently only useful internally when determining if a GV should be
1825created even in rvalue contexts.
1826
1827C<flags> is not used at present but available for future extension to
1828allow selecting particular classes of magical variable.
1829
b9b0e72c
NC
1830Currently assumes that C<name> is NUL terminated (as well as len being valid).
1831This assumption is met by all callers within the perl core, which all pass
1832pointers returned by SvPV.
1833
c9d5ac95
GS
1834=cut
1835*/
1836bool
1837Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1838{
b9b0e72c 1839 if (len > 1) {
9431620d 1840 const char *name1 = name + 1;
b9b0e72c
NC
1841 switch (*name) {
1842 case 'I':
9431620d 1843 if (len == 3 && name1[1] == 'S' && name[2] == 'A')
b9b0e72c
NC
1844 goto yes;
1845 break;
1846 case 'O':
9431620d 1847 if (len == 8 && strEQ(name1, "VERLOAD"))
b9b0e72c
NC
1848 goto yes;
1849 break;
1850 case 'S':
9431620d 1851 if (len == 3 && name[1] == 'I' && name[2] == 'G')
b9b0e72c
NC
1852 goto yes;
1853 break;
1854 /* Using ${^...} variables is likely to be sufficiently rare that
1855 it seems sensible to avoid the space hit of also checking the
1856 length. */
1857 case '\017': /* ${^OPEN} */
9431620d 1858 if (strEQ(name1, "PEN"))
b9b0e72c
NC
1859 goto yes;
1860 break;
1861 case '\024': /* ${^TAINT} */
9431620d 1862 if (strEQ(name1, "AINT"))
b9b0e72c
NC
1863 goto yes;
1864 break;
1865 case '\025': /* ${^UNICODE} */
9431620d 1866 if (strEQ(name1, "NICODE"))
b9b0e72c 1867 goto yes;
7cebcbc0
NC
1868 if (strEQ(name1, "TF8LOCALE"))
1869 goto yes;
b9b0e72c
NC
1870 break;
1871 case '\027': /* ${^WARNING_BITS} */
9431620d 1872 if (strEQ(name1, "ARNING_BITS"))
b9b0e72c
NC
1873 goto yes;
1874 break;
1875 case '1':
1876 case '2':
1877 case '3':
1878 case '4':
1879 case '5':
1880 case '6':
1881 case '7':
1882 case '8':
1883 case '9':
c9d5ac95 1884 {
c9d5ac95
GS
1885 char *end = name + len;
1886 while (--end > name) {
1887 if (!isDIGIT(*end))
1888 return FALSE;
1889 }
b9b0e72c
NC
1890 goto yes;
1891 }
1892 }
1893 } else {
1894 /* Because we're already assuming that name is NUL terminated
1895 below, we can treat an empty name as "\0" */
1896 switch (*name) {
1897 case '&':
1898 case '`':
1899 case '\'':
1900 case ':':
1901 case '?':
1902 case '!':
1903 case '-':
1904 case '#':
1905 case '[':
1906 case '^':
1907 case '~':
1908 case '=':
1909 case '%':
1910 case '.':
1911 case '(':
1912 case ')':
1913 case '<':
1914 case '>':
1915 case ',':
1916 case '\\':
1917 case '/':
1918 case '|':
1919 case '+':
1920 case ';':
1921 case ']':
1922 case '\001': /* $^A */
1923 case '\003': /* $^C */
1924 case '\004': /* $^D */
1925 case '\005': /* $^E */
1926 case '\006': /* $^F */
1927 case '\010': /* $^H */
1928 case '\011': /* $^I, NOT \t in EBCDIC */
1929 case '\014': /* $^L */
1930 case '\016': /* $^N */
1931 case '\017': /* $^O */
1932 case '\020': /* $^P */
1933 case '\023': /* $^S */
1934 case '\024': /* $^T */
1935 case '\026': /* $^V */
1936 case '\027': /* $^W */
1937 case '1':
1938 case '2':
1939 case '3':
1940 case '4':
1941 case '5':
1942 case '6':
1943 case '7':
1944 case '8':
1945 case '9':
1946 yes:
1947 return TRUE;
1948 default:
1949 break;
c9d5ac95 1950 }
c9d5ac95
GS
1951 }
1952 return FALSE;
1953}