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