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