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