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