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