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