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