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