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