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