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