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