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