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