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