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