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