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