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