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