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