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