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