This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
enable propagating exception objects via Perl_croak() in XS code
[perl5.git] / gv.c
CommitLineData
a0d0e21e 1/* gv.c
79072805 2 *
3818b22b 3 * Copyright (c) 1991-2000, Larry Wall
79072805
LW
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
a0d0e21e
LW
8 */
9
10/*
11 * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure
12 * of your inquisitiveness, I shall spend all the rest of my days answering
13 * you. What more do you want to know?'
14 * 'The names of all the stars, and of all living things, and the whole
15 * history of Middle-earth and Over-heaven and of the Sundering Seas,'
16 * laughed Pippin.
79072805
LW
17 */
18
19#include "EXTERN.h"
864dbfa3 20#define PERL_IN_GV_C
79072805
LW
21#include "perl.h"
22
23GV *
864dbfa3 24Perl_gv_AVadd(pTHX_ register GV *gv)
79072805 25{
a0d0e21e 26 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
cea2e8a9 27 Perl_croak(aTHX_ "Bad symbol for array");
79072805
LW
28 if (!GvAV(gv))
29 GvAV(gv) = newAV();
30 return gv;
31}
32
33GV *
864dbfa3 34Perl_gv_HVadd(pTHX_ register GV *gv)
79072805 35{
a0d0e21e 36 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
cea2e8a9 37 Perl_croak(aTHX_ "Bad symbol for hash");
79072805 38 if (!GvHV(gv))
463ee0b2 39 GvHV(gv) = newHV();
79072805
LW
40 return gv;
41}
42
43GV *
864dbfa3 44Perl_gv_IOadd(pTHX_ register GV *gv)
a0d0e21e
LW
45{
46 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
cea2e8a9 47 Perl_croak(aTHX_ "Bad symbol for filehandle");
a0d0e21e
LW
48 if (!GvIOp(gv))
49 GvIOp(gv) = newIO();
50 return gv;
51}
52
53GV *
864dbfa3 54Perl_gv_fetchfile(pTHX_ const char *name)
79072805 55{
e858de61 56 dTHR;
53d95988
CS
57 char smallbuf[256];
58 char *tmpbuf;
8ebc5c01 59 STRLEN tmplen;
79072805
LW
60 GV *gv;
61
1d7c1841
GS
62 if (!PL_defstash)
63 return Nullgv;
64
53d95988
CS
65 tmplen = strlen(name) + 2;
66 if (tmplen < sizeof smallbuf)
67 tmpbuf = smallbuf;
68 else
69 New(603, tmpbuf, tmplen + 1, char);
70 tmpbuf[0] = '_';
71 tmpbuf[1] = '<';
72 strcpy(tmpbuf + 2, name);
3280af22 73 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
1d7c1841 74 if (!isGV(gv)) {
3280af22 75 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
1d7c1841
GS
76 sv_setpv(GvSV(gv), name);
77 if (PERLDB_LINE)
78 hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
79 }
53d95988
CS
80 if (tmpbuf != smallbuf)
81 Safefree(tmpbuf);
79072805
LW
82 return gv;
83}
84
463ee0b2 85void
864dbfa3 86Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
463ee0b2 87{
0f15f207 88 dTHR;
463ee0b2 89 register GP *gp;
55d729e4
GS
90 bool doproto = SvTYPE(gv) > SVt_NULL;
91 char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
463ee0b2 92
dc437b57 93 sv_upgrade((SV*)gv, SVt_PVGV);
55d729e4
GS
94 if (SvLEN(gv)) {
95 if (proto) {
96 SvPVX(gv) = NULL;
97 SvLEN(gv) = 0;
98 SvPOK_off(gv);
99 } else
100 Safefree(SvPVX(gv));
101 }
44a8e56a 102 Newz(602, gp, 1, GP);
8990e307 103 GvGP(gv) = gp_ref(gp);
463ee0b2 104 GvSV(gv) = NEWSV(72,0);
1d7c1841
GS
105 GvLINE(gv) = CopLINE(PL_curcop);
106 GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
005a453c 107 GvCVGEN(gv) = 0;
463ee0b2
LW
108 GvEGV(gv) = gv;
109 sv_magic((SV*)gv, (SV*)gv, '*', name, len);
85aff577 110 GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
a0d0e21e 111 GvNAME(gv) = savepvn(name, len);
463ee0b2 112 GvNAMELEN(gv) = len;
23ad5bf5 113 if (multi || doproto) /* doproto means it _was_ mentioned */
a5f75d66 114 GvMULTI_on(gv);
55d729e4 115 if (doproto) { /* Replicate part of newSUB here. */
57ff9a15 116 SvIOK_off(gv);
55d729e4 117 ENTER;
b099ddc0 118 /* XXX unsafe for threads if eval_owner isn't held */
55d729e4 119 start_subparse(0,0); /* Create CV in compcv. */
3280af22 120 GvCV(gv) = PL_compcv;
55d729e4
GS
121 LEAVE;
122
3280af22 123 PL_sub_generation++;
55d729e4 124 CvGV(GvCV(gv)) = (GV*)SvREFCNT_inc(gv);
1d7c1841 125 CvFILE(GvCV(gv)) = CopFILE(PL_curcop);
3280af22 126 CvSTASH(GvCV(gv)) = PL_curstash;
55d729e4
GS
127#ifdef USE_THREADS
128 CvOWNER(GvCV(gv)) = 0;
1cfa4ec7 129 if (!CvMUTEXP(GvCV(gv))) {
b0a484d2 130 New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
1cfa4ec7
GS
131 MUTEX_INIT(CvMUTEXP(GvCV(gv)));
132 }
55d729e4
GS
133#endif /* USE_THREADS */
134 if (proto) {
135 sv_setpv((SV*)GvCV(gv), proto);
136 Safefree(proto);
137 }
138 }
463ee0b2
LW
139}
140
76e3520e 141STATIC void
cea2e8a9 142S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
a0d0e21e
LW
143{
144 switch (sv_type) {
145 case SVt_PVIO:
146 (void)GvIOn(gv);
147 break;
148 case SVt_PVAV:
149 (void)GvAVn(gv);
150 break;
151 case SVt_PVHV:
152 (void)GvHVn(gv);
153 break;
154 }
155}
156
954c1994
GS
157/*
158=for apidoc gv_fetchmeth
159
160Returns the glob with the given C<name> and a defined subroutine or
161C<NULL>. The glob lives in the given C<stash>, or in the stashes
162accessible via @ISA and @UNIVERSAL.
163
164The argument C<level> should be either 0 or -1. If C<level==0>, as a
165side-effect creates a glob with the given C<name> in the given C<stash>
166which in the case of success contains an alias for the subroutine, and sets
167up caching info for this glob. Similarly for all the searched stashes.
168
169This function grants C<"SUPER"> token as a postfix of the stash name. The
170GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
4929bf7b 171visible to Perl code. So when calling C<call_sv>, you should not use
954c1994
GS
172the GV directly; instead, you should use the method's CV, which can be
173obtained from the GV with the C<GvCV> macro.
174
175=cut
176*/
177
79072805 178GV *
864dbfa3 179Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
79072805
LW
180{
181 AV* av;
463ee0b2 182 GV* topgv;
79072805 183 GV* gv;
463ee0b2 184 GV** gvp;
748a9306 185 CV* cv;
a0d0e21e
LW
186
187 if (!stash)
188 return 0;
44a8e56a 189 if ((level > 100) || (level < -100))
cea2e8a9 190 Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
3e0ccd42 191 name, HvNAME(stash));
463ee0b2 192
cea2e8a9 193 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
44a8e56a
PP
194
195 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
196 if (!gvp)
197 topgv = Nullgv;
198 else {
199 topgv = *gvp;
200 if (SvTYPE(topgv) != SVt_PVGV)
201 gv_init(topgv, stash, name, len, TRUE);
155aba94 202 if ((cv = GvCV(topgv))) {
44a8e56a 203 /* If genuine method or valid cache entry, use it */
3280af22 204 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
7a4c00b4 205 return topgv;
44a8e56a
PP
206 /* Stale cached entry: junk it */
207 SvREFCNT_dec(cv);
208 GvCV(topgv) = cv = Nullcv;
209 GvCVGEN(topgv) = 0;
748a9306 210 }
3280af22 211 else if (GvCVGEN(topgv) == PL_sub_generation)
005a453c 212 return 0; /* cache indicates sub doesn't exist */
463ee0b2 213 }
79072805 214
9607fc9c 215 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
3280af22 216 av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
9607fc9c 217
fb73857a
PP
218 /* create and re-create @.*::SUPER::ISA on demand */
219 if (!av || !SvMAGIC(av)) {
9607fc9c
PP
220 char* packname = HvNAME(stash);
221 STRLEN packlen = strlen(packname);
222
223 if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
224 HV* basestash;
225
226 packlen -= 7;
227 basestash = gv_stashpvn(packname, packlen, TRUE);
228 gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
3280af22 229 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
e858de61 230 dTHR; /* just for SvREFCNT_dec */
9607fc9c
PP
231 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
232 if (!gvp || !(gv = *gvp))
cea2e8a9 233 Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
9607fc9c
PP
234 if (SvTYPE(gv) != SVt_PVGV)
235 gv_init(gv, stash, "ISA", 3, TRUE);
236 SvREFCNT_dec(GvAV(gv));
237 GvAV(gv) = (AV*)SvREFCNT_inc(av);
238 }
239 }
240 }
241
242 if (av) {
79072805 243 SV** svp = AvARRAY(av);
93965878
NIS
244 /* NOTE: No support for tied ISA */
245 I32 items = AvFILLp(av) + 1;
79072805 246 while (items--) {
79072805 247 SV* sv = *svp++;
a0d0e21e 248 HV* basestash = gv_stashsv(sv, FALSE);
9bbf4081 249 if (!basestash) {
d008e5eb 250 dTHR; /* just for ckWARN */
599cee73 251 if (ckWARN(WARN_MISC))
cea2e8a9 252 Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA",
463ee0b2 253 SvPVX(sv), HvNAME(stash));
79072805
LW
254 continue;
255 }
44a8e56a
PP
256 gv = gv_fetchmeth(basestash, name, len,
257 (level >= 0) ? level + 1 : level - 1);
258 if (gv)
259 goto gotcha;
79072805
LW
260 }
261 }
a0d0e21e 262
9607fc9c
PP
263 /* if at top level, try UNIVERSAL */
264
44a8e56a 265 if (level == 0 || level == -1) {
9607fc9c
PP
266 HV* lastchance;
267
155aba94
GS
268 if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
269 if ((gv = gv_fetchmeth(lastchance, name, len,
270 (level >= 0) ? level + 1 : level - 1)))
271 {
44a8e56a 272 gotcha:
dc848c6f
PP
273 /*
274 * Cache method in topgv if:
275 * 1. topgv has no synonyms (else inheritance crosses wires)
276 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
277 */
278 if (topgv &&
279 GvREFCNT(topgv) == 1 &&
280 (cv = GvCV(gv)) &&
281 (CvROOT(cv) || CvXSUB(cv)))
282 {
155aba94 283 if ((cv = GvCV(topgv)))
44a8e56a
PP
284 SvREFCNT_dec(cv);
285 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
3280af22 286 GvCVGEN(topgv) = PL_sub_generation;
44a8e56a 287 }
a0d0e21e
LW
288 return gv;
289 }
005a453c
JP
290 else if (topgv && GvREFCNT(topgv) == 1) {
291 /* cache the fact that the method is not defined */
3280af22 292 GvCVGEN(topgv) = PL_sub_generation;
005a453c 293 }
a0d0e21e
LW
294 }
295 }
296
79072805
LW
297 return 0;
298}
299
954c1994
GS
300/*
301=for apidoc gv_fetchmethod
302
6d0f518e 303See L<gv_fetchmethod_autoload>.
954c1994
GS
304
305=cut
306*/
307
79072805 308GV *
864dbfa3 309Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
463ee0b2 310{
dc848c6f
PP
311 return gv_fetchmethod_autoload(stash, name, TRUE);
312}
313
954c1994
GS
314/*
315=for apidoc gv_fetchmethod_autoload
316
317Returns the glob which contains the subroutine to call to invoke the method
318on the C<stash>. In fact in the presence of autoloading this may be the
319glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
320already setup.
321
322The third parameter of C<gv_fetchmethod_autoload> determines whether
323AUTOLOAD lookup is performed if the given method is not present: non-zero
324means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
325Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
326with a non-zero C<autoload> parameter.
327
328These functions grant C<"SUPER"> token as a prefix of the method name. Note
329that if you want to keep the returned glob for a long time, you need to
330check for it being "AUTOLOAD", since at the later time the call may load a
331different subroutine due to $AUTOLOAD changing its value. Use the glob
332created via a side effect to do this.
333
334These functions have the same side-effects and as C<gv_fetchmeth> with
335C<level==0>. C<name> should be writable if contains C<':'> or C<'
336''>. The warning against passing the GV returned by C<gv_fetchmeth> to
4929bf7b 337C<call_sv> apply equally to these functions.
954c1994
GS
338
339=cut
340*/
341
dc848c6f 342GV *
864dbfa3 343Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
dc848c6f 344{
0f15f207 345 dTHR;
08105a92
GS
346 register const char *nend;
347 const char *nsplit = 0;
a0d0e21e 348 GV* gv;
463ee0b2
LW
349
350 for (nend = name; *nend; nend++) {
9607fc9c 351 if (*nend == '\'')
a0d0e21e 352 nsplit = nend;
9607fc9c
PP
353 else if (*nend == ':' && *(nend + 1) == ':')
354 nsplit = ++nend;
a0d0e21e
LW
355 }
356 if (nsplit) {
08105a92 357 const char *origname = name;
a0d0e21e 358 name = nsplit + 1;
a0d0e21e
LW
359 if (*nsplit == ':')
360 --nsplit;
9607fc9c
PP
361 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
362 /* ->SUPER::method should really be looked up in original stash */
cea2e8a9 363 SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
1d7c1841 364 CopSTASHPV(PL_curcop)));
9607fc9c 365 stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
cea2e8a9 366 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
9607fc9c 367 origname, HvNAME(stash), name) );
4633a7c4 368 }
9607fc9c
PP
369 else
370 stash = gv_stashpvn(origname, nsplit - origname, TRUE);
4633a7c4
LW
371 }
372
9607fc9c 373 gv = gv_fetchmeth(stash, name, nend - name, 0);
a0d0e21e 374 if (!gv) {
702887b4 375 if (strEQ(name,"import"))
3280af22 376 gv = (GV*)&PL_sv_yes;
dc848c6f 377 else if (autoload)
54310121 378 gv = gv_autoload4(stash, name, nend - name, TRUE);
463ee0b2 379 }
dc848c6f
PP
380 else if (autoload) {
381 CV* cv = GvCV(gv);
09280a33
CS
382 if (!CvROOT(cv) && !CvXSUB(cv)) {
383 GV* stubgv;
384 GV* autogv;
385
386 if (CvANON(cv))
387 stubgv = gv;
388 else {
389 stubgv = CvGV(cv);
390 if (GvCV(stubgv) != cv) /* orphaned import */
391 stubgv = gv;
392 }
393 autogv = gv_autoload4(GvSTASH(stubgv),
394 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
dc848c6f
PP
395 if (autogv)
396 gv = autogv;
397 }
398 }
44a8e56a
PP
399
400 return gv;
401}
402
403GV*
864dbfa3 404Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
44a8e56a 405{
d008e5eb 406 dTHR;
44a8e56a
PP
407 static char autoload[] = "AUTOLOAD";
408 static STRLEN autolen = 8;
409 GV* gv;
410 CV* cv;
411 HV* varstash;
412 GV* vargv;
413 SV* varsv;
414
415 if (len == autolen && strnEQ(name, autoload, autolen))
416 return Nullgv;
dc848c6f
PP
417 if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
418 return Nullgv;
419 cv = GvCV(gv);
420
421 /*
422 * Inheriting AUTOLOAD for non-methods works ... for now.
423 */
599cee73
PM
424 if (ckWARN(WARN_DEPRECATED) && !method &&
425 (GvCVGEN(gv) || GvSTASH(gv) != stash))
cea2e8a9 426 Perl_warner(aTHX_ WARN_DEPRECATED,
dc848c6f
PP
427 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
428 HvNAME(stash), (int)len, name);
44a8e56a
PP
429
430 /*
431 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
432 * The subroutine's original name may not be "AUTOLOAD", so we don't
433 * use that, but for lack of anything better we will use the sub's
434 * original package to look up $AUTOLOAD.
435 */
436 varstash = GvSTASH(CvGV(cv));
437 vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
438 if (!isGV(vargv))
439 gv_init(vargv, varstash, autoload, autolen, FALSE);
440 varsv = GvSV(vargv);
441 sv_setpv(varsv, HvNAME(stash));
442 sv_catpvn(varsv, "::", 2);
443 sv_catpvn(varsv, name, len);
444 SvTAINTED_off(varsv);
a0d0e21e
LW
445 return gv;
446}
447
954c1994
GS
448/*
449=for apidoc gv_stashpv
450
386d01d6
GS
451Returns a pointer to the stash for a specified package. C<name> should
452be a valid UTF-8 string. If C<create> is set then the package will be
453created if it does not already exist. If C<create> is not set and the
454package does not exist then NULL is returned.
954c1994
GS
455
456=cut
457*/
458
a0d0e21e 459HV*
864dbfa3 460Perl_gv_stashpv(pTHX_ const char *name, I32 create)
a0d0e21e 461{
dc437b57
PP
462 return gv_stashpvn(name, strlen(name), create);
463}
464
465HV*
864dbfa3 466Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
dc437b57 467{
46fc3d4c
PP
468 char smallbuf[256];
469 char *tmpbuf;
a0d0e21e
LW
470 HV *stash;
471 GV *tmpgv;
dc437b57 472
46fc3d4c
PP
473 if (namelen + 3 < sizeof smallbuf)
474 tmpbuf = smallbuf;
475 else
476 New(606, tmpbuf, namelen + 3, char);
dc437b57
PP
477 Copy(name,tmpbuf,namelen,char);
478 tmpbuf[namelen++] = ':';
479 tmpbuf[namelen++] = ':';
480 tmpbuf[namelen] = '\0';
46fc3d4c
PP
481 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
482 if (tmpbuf != smallbuf)
483 Safefree(tmpbuf);
a0d0e21e
LW
484 if (!tmpgv)
485 return 0;
486 if (!GvHV(tmpgv))
487 GvHV(tmpgv) = newHV();
488 stash = GvHV(tmpgv);
489 if (!HvNAME(stash))
490 HvNAME(stash) = savepv(name);
491 return stash;
463ee0b2
LW
492}
493
954c1994
GS
494/*
495=for apidoc gv_stashsv
496
386d01d6
GS
497Returns a pointer to the stash for a specified package, which must be a
498valid UTF-8 string. See C<gv_stashpv>.
954c1994
GS
499
500=cut
501*/
502
a0d0e21e 503HV*
864dbfa3 504Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
a0d0e21e 505{
dc437b57
PP
506 register char *ptr;
507 STRLEN len;
508 ptr = SvPV(sv,len);
509 return gv_stashpvn(ptr, len, create);
a0d0e21e
LW
510}
511
512
463ee0b2 513GV *
864dbfa3 514Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
79072805 515{
11343788 516 dTHR;
08105a92 517 register const char *name = nambeg;
463ee0b2 518 register GV *gv = 0;
79072805 519 GV**gvp;
79072805 520 I32 len;
08105a92 521 register const char *namend;
463ee0b2 522 HV *stash = 0;
79072805 523
c07a80fd
PP
524 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
525 name++;
526
79072805 527 for (namend = name; *namend; namend++) {
1d7c1841
GS
528 if ((*namend == ':' && namend[1] == ':')
529 || (*namend == '\'' && namend[1]))
463ee0b2 530 {
463ee0b2 531 if (!stash)
3280af22 532 stash = PL_defstash;
dc437b57 533 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
a0d0e21e 534 return Nullgv;
463ee0b2 535
85e6fe83
LW
536 len = namend - name;
537 if (len > 0) {
3c78fafa 538 char smallbuf[256];
62b57502 539 char *tmpbuf;
62b57502 540
3c78fafa
GS
541 if (len + 3 < sizeof smallbuf)
542 tmpbuf = smallbuf;
62b57502
MB
543 else
544 New(601, tmpbuf, len+3, char);
a0d0e21e
LW
545 Copy(name, tmpbuf, len, char);
546 tmpbuf[len++] = ':';
547 tmpbuf[len++] = ':';
548 tmpbuf[len] = '\0';
463ee0b2 549 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
6fa846a0 550 gv = gvp ? *gvp : Nullgv;
3280af22 551 if (gv && gv != (GV*)&PL_sv_undef) {
6fa846a0 552 if (SvTYPE(gv) != SVt_PVGV)
0f303493 553 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
6fa846a0
GS
554 else
555 GvMULTI_on(gv);
556 }
3c78fafa 557 if (tmpbuf != smallbuf)
62b57502 558 Safefree(tmpbuf);
3280af22 559 if (!gv || gv == (GV*)&PL_sv_undef)
a0d0e21e 560 return Nullgv;
85e6fe83 561
463ee0b2
LW
562 if (!(stash = GvHV(gv)))
563 stash = GvHV(gv) = newHV();
85e6fe83 564
463ee0b2 565 if (!HvNAME(stash))
a0d0e21e 566 HvNAME(stash) = savepvn(nambeg, namend - nambeg);
463ee0b2
LW
567 }
568
569 if (*namend == ':')
570 namend++;
571 namend++;
572 name = namend;
573 if (!*name)
3280af22 574 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
79072805 575 }
79072805 576 }
a0d0e21e
LW
577 len = namend - name;
578 if (!len)
579 len = 1;
463ee0b2
LW
580
581 /* No stash in name, so see how we can default */
582
583 if (!stash) {
7e2040f0 584 if (isIDFIRST_lazy(name)) {
9607fc9c
PP
585 bool global = FALSE;
586
463ee0b2 587 if (isUPPER(*name)) {
9d116dd7
JH
588 if (*name == 'S' && (
589 strEQ(name, "SIG") ||
590 strEQ(name, "STDIN") ||
591 strEQ(name, "STDOUT") ||
592 strEQ(name, "STDERR")))
593 global = TRUE;
594 else if (*name == 'I' && strEQ(name, "INC"))
595 global = TRUE;
596 else if (*name == 'E' && strEQ(name, "ENV"))
597 global = TRUE;
463ee0b2
LW
598 else if (*name == 'A' && (
599 strEQ(name, "ARGV") ||
9d116dd7 600 strEQ(name, "ARGVOUT")))
463ee0b2
LW
601 global = TRUE;
602 }
603 else if (*name == '_' && !name[1])
604 global = TRUE;
9607fc9c 605
463ee0b2 606 if (global)
3280af22
NIS
607 stash = PL_defstash;
608 else if ((COP*)PL_curcop == &PL_compiling) {
609 stash = PL_curstash;
610 if (add && (PL_hints & HINT_STRICT_VARS) &&
748a9306
LW
611 sv_type != SVt_PVCV &&
612 sv_type != SVt_PVGV &&
4633a7c4 613 sv_type != SVt_PVFM &&
c07a80fd 614 sv_type != SVt_PVIO &&
377b8fbc 615 !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
748a9306 616 {
4633a7c4
LW
617 gvp = (GV**)hv_fetch(stash,name,len,0);
618 if (!gvp ||
3280af22 619 *gvp == (GV*)&PL_sv_undef ||
a5f75d66
AD
620 SvTYPE(*gvp) != SVt_PVGV)
621 {
4633a7c4 622 stash = 0;
a5f75d66 623 }
155aba94
GS
624 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
625 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
626 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
4633a7c4 627 {
cea2e8a9 628 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
4633a7c4
LW
629 sv_type == SVt_PVAV ? '@' :
630 sv_type == SVt_PVHV ? '%' : '$',
631 name);
8ebc5c01 632 if (GvCVu(*gvp))
cc507455 633 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
a0d0e21e 634 stash = 0;
4633a7c4 635 }
a0d0e21e 636 }
85e6fe83 637 }
463ee0b2 638 else
1d7c1841 639 stash = CopSTASH(PL_curcop);
463ee0b2
LW
640 }
641 else
3280af22 642 stash = PL_defstash;
463ee0b2
LW
643 }
644
645 /* By this point we should have a stash and a name */
646
a0d0e21e 647 if (!stash) {
5a844595
GS
648 if (add) {
649 qerror(Perl_mess(aTHX_
650 "Global symbol \"%s%s\" requires explicit package name",
651 (sv_type == SVt_PV ? "$"
652 : sv_type == SVt_PVAV ? "@"
653 : sv_type == SVt_PVHV ? "%"
654 : ""), name));
f180df80 655 stash = PL_nullstash;
a0d0e21e 656 }
f180df80
GS
657 else
658 return Nullgv;
a0d0e21e
LW
659 }
660
661 if (!SvREFCNT(stash)) /* symbol table under destruction */
662 return Nullgv;
663
79072805 664 gvp = (GV**)hv_fetch(stash,name,len,add);
3280af22 665 if (!gvp || *gvp == (GV*)&PL_sv_undef)
79072805
LW
666 return Nullgv;
667 gv = *gvp;
668 if (SvTYPE(gv) == SVt_PVGV) {
a0d0e21e 669 if (add) {
a5f75d66 670 GvMULTI_on(gv);
a0d0e21e
LW
671 gv_init_sv(gv, sv_type);
672 }
79072805 673 return gv;
55d729e4
GS
674 } else if (add & GV_NOINIT) {
675 return gv;
79072805 676 }
93a17b20
LW
677
678 /* Adding a new symbol */
679
0453d815
PM
680 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
681 Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg);
55d729e4 682 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
a0d0e21e 683 gv_init_sv(gv, sv_type);
93a17b20 684
0453d815
PM
685 if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE))
686 GvMULTI_on(gv) ;
687
93a17b20
LW
688 /* set up magic where warranted */
689 switch (*name) {
a0d0e21e
LW
690 case 'A':
691 if (strEQ(name, "ARGV")) {
692 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
693 }
694 break;
a0d0e21e
LW
695 case 'E':
696 if (strnEQ(name, "EXPORT", 6))
a5f75d66 697 GvMULTI_on(gv);
a0d0e21e 698 break;
463ee0b2
LW
699 case 'I':
700 if (strEQ(name, "ISA")) {
701 AV* av = GvAVn(gv);
a5f75d66 702 GvMULTI_on(gv);
a0d0e21e 703 sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
93965878 704 /* NOTE: No support for tied ISA */
55d729e4
GS
705 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
706 && AvFILLp(av) == -1)
85e6fe83 707 {
a0d0e21e 708 char *pname;
79cb57f6 709 av_push(av, newSVpvn(pname = "NDBM_File",9));
dc437b57 710 gv_stashpvn(pname, 9, TRUE);
79cb57f6 711 av_push(av, newSVpvn(pname = "DB_File",7));
dc437b57 712 gv_stashpvn(pname, 7, TRUE);
79cb57f6 713 av_push(av, newSVpvn(pname = "GDBM_File",9));
dc437b57 714 gv_stashpvn(pname, 9, TRUE);
79cb57f6 715 av_push(av, newSVpvn(pname = "SDBM_File",9));
dc437b57 716 gv_stashpvn(pname, 9, TRUE);
79cb57f6 717 av_push(av, newSVpvn(pname = "ODBM_File",9));
dc437b57 718 gv_stashpvn(pname, 9, TRUE);
85e6fe83 719 }
463ee0b2
LW
720 }
721 break;
a0d0e21e
LW
722 case 'O':
723 if (strEQ(name, "OVERLOAD")) {
724 HV* hv = GvHVn(gv);
a5f75d66 725 GvMULTI_on(gv);
ea0efc06 726 hv_magic(hv, gv, 'A');
a0d0e21e
LW
727 }
728 break;
93a17b20
LW
729 case 'S':
730 if (strEQ(name, "SIG")) {
731 HV *hv;
dc437b57 732 I32 i;
1d7c1841
GS
733 if (!PL_psig_ptr) {
734 int sig_num[] = { SIG_NUM };
735 New(73, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
736 New(73, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
737 }
738 GvMULTI_on(gv);
739 hv = GvHVn(gv);
740 hv_magic(hv, gv, 'S');
741 for (i = 1; PL_sig_name[i]; i++) {
dc437b57 742 SV ** init;
1d7c1841
GS
743 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
744 if (init)
745 sv_setsv(*init, &PL_sv_undef);
22c35a8c
GS
746 PL_psig_ptr[i] = 0;
747 PL_psig_name[i] = 0;
dc437b57 748 }
93a17b20
LW
749 }
750 break;
09bef843
SB
751 case 'V':
752 if (strEQ(name, "VERSION"))
753 GvMULTI_on(gv);
754 break;
93a17b20
LW
755
756 case '&':
463ee0b2
LW
757 if (len > 1)
758 break;
3280af22 759 PL_sawampersand = TRUE;
a0d0e21e 760 goto ro_magicalize;
93a17b20
LW
761
762 case '`':
463ee0b2
LW
763 if (len > 1)
764 break;
3280af22 765 PL_sawampersand = TRUE;
a0d0e21e 766 goto ro_magicalize;
93a17b20
LW
767
768 case '\'':
463ee0b2
LW
769 if (len > 1)
770 break;
3280af22 771 PL_sawampersand = TRUE;
a0d0e21e 772 goto ro_magicalize;
93a17b20
LW
773
774 case ':':
463ee0b2
LW
775 if (len > 1)
776 break;
3280af22 777 sv_setpv(GvSV(gv),PL_chopset);
93a17b20
LW
778 goto magicalize;
779
ff0cee69
PP
780 case '?':
781 if (len > 1)
782 break;
783#ifdef COMPLEX_STATUS
07f14f54 784 (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
ff0cee69
PP
785#endif
786 goto magicalize;
787
067391ea 788 case '!':
4318d5a0 789 if (len > 1)
067391ea 790 break;
3280af22 791 if (sv_type > SVt_PV && PL_curcop != &PL_compiling) {
067391ea 792 HV* stash = gv_stashpvn("Errno",5,FALSE);
265f5c4a 793 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
067391ea
GS
794 dSP;
795 PUTBACK;
cea2e8a9 796 require_pv("Errno.pm");
067391ea
GS
797 SPAGAIN;
798 stash = gv_stashpvn("Errno",5,FALSE);
799 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
cea2e8a9 800 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
067391ea
GS
801 }
802 }
803 goto magicalize;
6cef1e77
IZ
804 case '-':
805 if (len > 1)
806 break;
807 else {
808 AV* av = GvAVn(gv);
809 sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
810 }
811 goto magicalize;
93a17b20 812 case '#':
a0d0e21e 813 case '*':
599cee73 814 if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
cea2e8a9 815 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
a0d0e21e
LW
816 /* FALL THROUGH */
817 case '[':
93a17b20
LW
818 case '^':
819 case '~':
820 case '=':
93a17b20
LW
821 case '%':
822 case '.':
93a17b20
LW
823 case '(':
824 case ')':
825 case '<':
826 case '>':
827 case ',':
828 case '\\':
829 case '/':
93a17b20 830 case '|':
16070b82
GS
831 case '\001': /* $^A */
832 case '\003': /* $^C */
833 case '\004': /* $^D */
834 case '\005': /* $^E */
835 case '\006': /* $^F */
836 case '\010': /* $^H */
837 case '\011': /* $^I, NOT \t in EBCDIC */
838 case '\017': /* $^O */
839 case '\020': /* $^P */
840 case '\024': /* $^T */
463ee0b2
LW
841 if (len > 1)
842 break;
843 goto magicalize;
16070b82 844 case '\023': /* $^S */
6cef1e77
IZ
845 if (len > 1)
846 break;
847 goto ro_magicalize;
6a818117 848 case '\027': /* $^W & $^WARNING_BITS */
a50e31ad
GS
849 if (len > 1 && strNE(name, "\027ARNING_BITS")
850 && strNE(name, "\027IDE_SYSTEM_CALLS"))
4438c4b7
JH
851 break;
852 goto magicalize;
463ee0b2 853
a0d0e21e 854 case '+':
6cef1e77
IZ
855 if (len > 1)
856 break;
857 else {
858 AV* av = GvAVn(gv);
859 sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
860 }
861 /* FALL THROUGH */
463ee0b2
LW
862 case '1':
863 case '2':
864 case '3':
865 case '4':
866 case '5':
867 case '6':
868 case '7':
869 case '8':
870 case '9':
a0d0e21e
LW
871 ro_magicalize:
872 SvREADONLY_on(GvSV(gv));
93a17b20 873 magicalize:
463ee0b2 874 sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
93a17b20
LW
875 break;
876
16070b82 877 case '\014': /* $^L */
463ee0b2
LW
878 if (len > 1)
879 break;
93a17b20 880 sv_setpv(GvSV(gv),"\f");
3280af22 881 PL_formfeed = GvSV(gv);
93a17b20
LW
882 break;
883 case ';':
463ee0b2
LW
884 if (len > 1)
885 break;
93a17b20
LW
886 sv_setpv(GvSV(gv),"\034");
887 break;
463ee0b2
LW
888 case ']':
889 if (len == 1) {
f86702cc 890 SV *sv = GvSV(gv);
5089c844
GS
891 (void)SvUPGRADE(sv, SVt_PVNV);
892 SvNVX(sv) = SvNVX(PL_patchlevel);
893 SvNOK_on(sv);
894 (void)SvPV_nolen(sv);
895 SvREADONLY_on(sv);
93a17b20
LW
896 }
897 break;
16070b82
GS
898 case '\026': /* $^V */
899 if (len == 1) {
900 SV *sv = GvSV(gv);
901 GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
902 SvREFCNT_dec(sv);
903 }
904 break;
79072805 905 }
93a17b20 906 return gv;
79072805
LW
907}
908
909void
864dbfa3 910Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
79072805
LW
911{
912 HV *hv = GvSTASH(gv);
f967eb5f 913 if (!hv) {
155aba94 914 (void)SvOK_off(sv);
79072805 915 return;
f967eb5f
PP
916 }
917 sv_setpv(sv, prefix ? prefix : "");
79072805 918 sv_catpv(sv,HvNAME(hv));
463ee0b2 919 sv_catpvn(sv,"::", 2);
79072805
LW
920 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
921}
922
923void
864dbfa3 924Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
79072805 925{
f967eb5f 926 GV *egv = GvEGV(gv);
748a9306
LW
927 if (!egv)
928 egv = gv;
f6aff53a
PP
929 gv_fullname3(sv, egv, prefix);
930}
931
932/* XXX compatibility with versions <= 5.003. */
933void
864dbfa3 934Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
f6aff53a
PP
935{
936 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
937}
938
939/* XXX compatibility with versions <= 5.003. */
940void
864dbfa3 941Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
f6aff53a
PP
942{
943 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
79072805
LW
944}
945
946IO *
864dbfa3 947Perl_newIO(pTHX)
79072805 948{
11343788 949 dTHR;
79072805 950 IO *io;
8990e307
LW
951 GV *iogv;
952
953 io = (IO*)NEWSV(0,0);
a0d0e21e 954 sv_upgrade((SV *)io,SVt_PVIO);
8990e307
LW
955 SvREFCNT(io) = 1;
956 SvOBJECT_on(io);
c9de509e 957 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
5f2d631d
GS
958 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
959 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
c9de509e 960 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
8990e307 961 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
79072805
LW
962 return io;
963}
964
965void
864dbfa3 966Perl_gv_check(pTHX_ HV *stash)
79072805 967{
11343788 968 dTHR;
79072805
LW
969 register HE *entry;
970 register I32 i;
971 register GV *gv;
463ee0b2
LW
972 HV *hv;
973
8990e307
LW
974 if (!HvARRAY(stash))
975 return;
a0d0e21e 976 for (i = 0; i <= (I32) HvMAX(stash); i++) {
dc437b57
PP
977 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
978 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
979 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
a0d0e21e 980 {
19b6c847 981 if (hv != PL_defstash && hv != stash)
a0d0e21e
LW
982 gv_check(hv); /* nested package */
983 }
dc437b57 984 else if (isALPHA(*HeKEY(entry))) {
1d7c1841 985 char *file;
dc437b57 986 gv = (GV*)HeVAL(entry);
55d729e4 987 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
463ee0b2 988 continue;
1d7c1841
GS
989 file = GvFILE(gv);
990 /* performance hack: if filename is absolute and it's a standard
991 * module, don't bother warning */
992 if (file
993 && PERL_FILE_IS_ABSOLUTE(file)
994 && (instr(file, "/lib/") || instr(file, ".pm")))
995 {
8990e307 996 continue;
1d7c1841
GS
997 }
998 CopLINE_set(PL_curcop, GvLINE(gv));
999#ifdef USE_ITHREADS
1000 CopFILE(PL_curcop) = file; /* set for warning */
1001#else
1002 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1003#endif
cea2e8a9 1004 Perl_warner(aTHX_ WARN_ONCE,
599cee73 1005 "Name \"%s::%s\" used only once: possible typo",
a0d0e21e 1006 HvNAME(stash), GvNAME(gv));
463ee0b2 1007 }
79072805
LW
1008 }
1009 }
1010}
1011
1012GV *
864dbfa3 1013Perl_newGVgen(pTHX_ char *pack)
79072805 1014{
cea2e8a9 1015 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
46fc3d4c 1016 TRUE, SVt_PVGV);
79072805
LW
1017}
1018
1019/* hopefully this is only called on local symbol table entries */
1020
1021GP*
864dbfa3 1022Perl_gp_ref(pTHX_ GP *gp)
79072805 1023{
1d7c1841
GS
1024 if (!gp)
1025 return (GP*)NULL;
79072805 1026 gp->gp_refcnt++;
44a8e56a
PP
1027 if (gp->gp_cv) {
1028 if (gp->gp_cvgen) {
1029 /* multi-named GPs cannot be used for method cache */
1030 SvREFCNT_dec(gp->gp_cv);
1031 gp->gp_cv = Nullcv;
1032 gp->gp_cvgen = 0;
1033 }
1034 else {
1035 /* Adding a new name to a subroutine invalidates method cache */
3280af22 1036 PL_sub_generation++;
44a8e56a
PP
1037 }
1038 }
79072805 1039 return gp;
79072805
LW
1040}
1041
1042void
864dbfa3 1043Perl_gp_free(pTHX_ GV *gv)
79072805 1044{
f248d071 1045 dTHR;
79072805
LW
1046 GP* gp;
1047
1048 if (!gv || !(gp = GvGP(gv)))
1049 return;
f248d071
GS
1050 if (gp->gp_refcnt == 0) {
1051 if (ckWARN_d(WARN_INTERNAL))
1052 Perl_warner(aTHX_ WARN_INTERNAL,
1053 "Attempt to free unreferenced glob pointers");
79072805
LW
1054 return;
1055 }
44a8e56a
PP
1056 if (gp->gp_cv) {
1057 /* Deleting the name of a subroutine invalidates method cache */
3280af22 1058 PL_sub_generation++;
44a8e56a 1059 }
748a9306
LW
1060 if (--gp->gp_refcnt > 0) {
1061 if (gp->gp_egv == gv)
1062 gp->gp_egv = 0;
79072805 1063 return;
748a9306 1064 }
79072805 1065
8990e307
LW
1066 SvREFCNT_dec(gp->gp_sv);
1067 SvREFCNT_dec(gp->gp_av);
1068 SvREFCNT_dec(gp->gp_hv);
377b8fbc 1069 SvREFCNT_dec(gp->gp_io);
a6006777 1070 SvREFCNT_dec(gp->gp_cv);
748a9306
LW
1071 SvREFCNT_dec(gp->gp_form);
1072
79072805
LW
1073 Safefree(gp);
1074 GvGP(gv) = 0;
1075}
1076
1077#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1078#define MICROPORT
1079#endif
1080
1081#ifdef MICROPORT /* Microport 2.4 hack */
1082AV *GvAVn(gv)
1083register GV *gv;
1084{
1085 if (GvGP(gv)->gp_av)
1086 return GvGP(gv)->gp_av;
1087 else
1088 return GvGP(gv_AVadd(gv))->gp_av;
1089}
1090
1091HV *GvHVn(gv)
1092register GV *gv;
1093{
1094 if (GvGP(gv)->gp_hv)
1095 return GvGP(gv)->gp_hv;
1096 else
1097 return GvGP(gv_HVadd(gv))->gp_hv;
1098}
1099#endif /* Microport 2.4 hack */
a0d0e21e 1100
a0d0e21e
LW
1101/* Updates and caches the CV's */
1102
1103bool
864dbfa3 1104Perl_Gv_AMupdate(pTHX_ HV *stash)
a0d0e21e 1105{
155aba94 1106 dTHR;
a0d0e21e
LW
1107 GV* gv;
1108 CV* cv;
1109 MAGIC* mg=mg_find((SV*)stash,'c');
8ac85365 1110 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
a6006777 1111 AMT amt;
2d8e6c8d 1112 STRLEN n_a;
155aba94
GS
1113#ifdef OVERLOAD_VIA_HASH
1114 GV** gvp;
1115 HV* hv;
1116#endif
a0d0e21e 1117
3280af22
NIS
1118 if (mg && amtp->was_ok_am == PL_amagic_generation
1119 && amtp->was_ok_sub == PL_sub_generation)
a6006777
PP
1120 return AMT_AMAGIC(amtp);
1121 if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */
748a9306 1122 int i;
a6006777 1123 for (i=1; i<NofAMmeth; i++) {
748a9306
LW
1124 if (amtp->table[i]) {
1125 SvREFCNT_dec(amtp->table[i]);
1126 }
1127 }
1128 }
a0d0e21e
LW
1129 sv_unmagic((SV*)stash, 'c');
1130
cea2e8a9 1131 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
a0d0e21e 1132
3280af22
NIS
1133 amt.was_ok_am = PL_amagic_generation;
1134 amt.was_ok_sub = PL_sub_generation;
a6006777
PP
1135 amt.fallback = AMGfallNO;
1136 amt.flags = 0;
1137
1138#ifdef OVERLOAD_VIA_HASH
1139 gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
3280af22 1140 if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
a0d0e21e
LW
1141 int filled=0;
1142 int i;
1143 char *cp;
a0d0e21e
LW
1144 SV* sv;
1145 SV** svp;
a0d0e21e 1146
22c35a8c 1147 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
a0d0e21e 1148
22c35a8c 1149 if (( cp = (char *)PL_AMG_names[0] ) &&
a6006777 1150 (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
a0d0e21e
LW
1151 if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1152 else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1153 }
a6006777
PP
1154 for (i = 1; i < NofAMmeth; i++) {
1155 cv = 0;
22c35a8c 1156 cp = (char *)PL_AMG_names[i];
a6006777
PP
1157
1158 svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
3280af22 1159 if (svp && ((sv = *svp) != &PL_sv_undef)) {
a0d0e21e
LW
1160 switch (SvTYPE(sv)) {
1161 default:
1162 if (!SvROK(sv)) {
1163 if (!SvOK(sv)) break;
2d8e6c8d 1164 gv = gv_fetchmethod(stash, SvPV(sv, n_a));
a0d0e21e
LW
1165 if (gv) cv = GvCV(gv);
1166 break;
1167 }
1168 cv = (CV*)SvRV(sv);
1169 if (SvTYPE(cv) == SVt_PVCV)
1170 break;
1171 /* FALL THROUGH */
1172 case SVt_PVHV:
1173 case SVt_PVAV:
cea2e8a9 1174 Perl_croak(aTHX_ "Not a subroutine reference in overload table");
a0d0e21e
LW
1175 return FALSE;
1176 case SVt_PVCV:
8ebc5c01
PP
1177 cv = (CV*)sv;
1178 break;
a0d0e21e 1179 case SVt_PVGV:
8ebc5c01 1180 if (!(cv = GvCVu((GV*)sv)))
f6ec51f7 1181 cv = sv_2cv(sv, &stash, &gv, FALSE);
8ebc5c01 1182 break;
a0d0e21e
LW
1183 }
1184 if (cv) filled=1;
1185 else {
cea2e8a9 1186 Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
a0d0e21e
LW
1187 cp,HvNAME(stash));
1188 return FALSE;
1189 }
1190 }
a6006777
PP
1191#else
1192 {
1193 int filled = 0;
1194 int i;
9607fc9c 1195 const char *cp;
a6006777 1196 SV* sv = NULL;
a6006777 1197
22c35a8c 1198 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
a6006777 1199
155aba94 1200 if ((cp = PL_AMG_names[0])) {
a6006777 1201 /* Try to find via inheritance. */
774d564b 1202 gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
155aba94
GS
1203 if (gv)
1204 sv = GvSV(gv);
1205
1206 if (!gv)
1207 goto no_table;
1208 else if (SvTRUE(sv))
1209 amt.fallback=AMGfallYES;
1210 else if (SvOK(sv))
1211 amt.fallback=AMGfallNEVER;
a6006777
PP
1212 }
1213
1214 for (i = 1; i < NofAMmeth; i++) {
cea2e8a9
GS
1215 SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
1216 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
44a8e56a 1217 cp, HvNAME(stash)) );
46fc3d4c
PP
1218 /* don't fill the cache while looking up! */
1219 gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
1220 cv = 0;
44a8e56a 1221 if(gv && (cv = GvCV(gv))) {
44a8e56a
PP
1222 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1223 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1224 /* GvSV contains the name of the method. */
1225 GV *ngv;
1226
cea2e8a9 1227 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
2d8e6c8d 1228 SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
dc848c6f
PP
1229 if (!SvPOK(GvSV(gv))
1230 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1231 FALSE)))
1232 {
44a8e56a
PP
1233 /* Can be an import stub (created by `can'). */
1234 if (GvCVGEN(gv)) {
cea2e8a9 1235 Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
44a8e56a
PP
1236 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1237 cp, HvNAME(stash));
1238 } else
cea2e8a9 1239 Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
44a8e56a
PP
1240 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1241 cp, HvNAME(stash));
1242 }
dc848c6f 1243 cv = GvCV(gv = ngv);
44a8e56a 1244 }
cea2e8a9 1245 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
44a8e56a
PP
1246 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1247 GvNAME(CvGV(cv))) );
1248 filled = 1;
1249 }
a6006777
PP
1250#endif
1251 amt.table[i]=(CV*)SvREFCNT_inc(cv);
a0d0e21e 1252 }
a0d0e21e 1253 if (filled) {
a6006777
PP
1254 AMT_AMAGIC_on(&amt);
1255 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
a0d0e21e
LW
1256 return TRUE;
1257 }
1258 }
a6006777 1259 /* Here we have no table: */
774d564b 1260 no_table:
a6006777
PP
1261 AMT_AMAGIC_off(&amt);
1262 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
a0d0e21e
LW
1263 return FALSE;
1264}
1265
a0d0e21e 1266SV*
864dbfa3 1267Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
a0d0e21e 1268{
11343788 1269 dTHR;
a0d0e21e
LW
1270 MAGIC *mg;
1271 CV *cv;
1272 CV **cvp=NULL, **ocvp=NULL;
1273 AMT *amtp, *oamtp;
1274 int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
ee239bfe 1275 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
a0d0e21e
LW
1276 HV* stash;
1277 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1278 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
a6006777
PP
1279 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1280 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
8ac85365 1281 : (CV **) NULL))
748a9306
LW
1282 && ((cv = cvp[off=method+assignshift])
1283 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1284 * usual method */
1285 (fl = 1, cv = cvp[off=method])))) {
a0d0e21e
LW
1286 lr = -1; /* Call method for left argument */
1287 } else {
1288 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1289 int logic;
1290
1291 /* look for substituted methods */
ee239bfe 1292 /* In all the covered cases we should be called with assign==0. */
a0d0e21e
LW
1293 switch (method) {
1294 case inc_amg:
ee239bfe
IZ
1295 force_cpy = 1;
1296 if ((cv = cvp[off=add_ass_amg])
1297 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3280af22 1298 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1299 }
1300 break;
1301 case dec_amg:
ee239bfe
IZ
1302 force_cpy = 1;
1303 if ((cv = cvp[off = subtr_ass_amg])
1304 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3280af22 1305 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1306 }
1307 break;
1308 case bool__amg:
1309 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1310 break;
1311 case numer_amg:
1312 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1313 break;
1314 case string_amg:
1315 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1316 break;
dc437b57
PP
1317 case not_amg:
1318 (void)((cv = cvp[off=bool__amg])
1319 || (cv = cvp[off=numer_amg])
1320 || (cv = cvp[off=string_amg]));
1321 postpr = 1;
1322 break;
748a9306
LW
1323 case copy_amg:
1324 {
76e3520e
GS
1325 /*
1326 * SV* ref causes confusion with the interpreter variable of
1327 * the same name
1328 */
1329 SV* tmpRef=SvRV(left);
1330 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
fc36a67e
PP
1331 /*
1332 * Just to be extra cautious. Maybe in some
1333 * additional cases sv_setsv is safe, too.
1334 */
76e3520e 1335 SV* newref = newSVsv(tmpRef);
748a9306 1336 SvOBJECT_on(newref);
76e3520e 1337 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
748a9306
LW
1338 return newref;
1339 }
1340 }
1341 break;
a0d0e21e 1342 case abs_amg:
748a9306 1343 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
a0d0e21e 1344 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
748a9306 1345 SV* nullsv=sv_2mortal(newSViv(0));
a0d0e21e 1346 if (off1==lt_amg) {
748a9306 1347 SV* lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1348 lt_amg,AMGf_noright);
1349 logic = SvTRUE(lessp);
1350 } else {
748a9306 1351 SV* lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1352 ncmp_amg,AMGf_noright);
1353 logic = (SvNV(lessp) < 0);
1354 }
1355 if (logic) {
1356 if (off==subtr_amg) {
1357 right = left;
748a9306 1358 left = nullsv;
a0d0e21e
LW
1359 lr = 1;
1360 }
1361 } else {
1362 return left;
1363 }
1364 }
1365 break;
1366 case neg_amg:
155aba94 1367 if ((cv = cvp[off=subtr_amg])) {
a0d0e21e
LW
1368 right = left;
1369 left = sv_2mortal(newSViv(0));
1370 lr = 1;
1371 }
1372 break;
f5284f61
IZ
1373 case iter_amg: /* XXXX Eventually should do to_gv. */
1374 case to_sv_amg:
1375 case to_av_amg:
1376 case to_hv_amg:
1377 case to_gv_amg:
1378 case to_cv_amg:
1379 /* FAIL safe */
1380 return NULL; /* Delegate operation to standard mechanisms. */
1381 break;
a0d0e21e
LW
1382 default:
1383 goto not_found;
1384 }
1385 if (!cv) goto not_found;
1386 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1387 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
a6006777
PP
1388 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1389 ? (amtp = (AMT*)mg->mg_ptr)->table
8ac85365 1390 : (CV **) NULL))
a0d0e21e
LW
1391 && (cv = cvp[off=method])) { /* Method for right
1392 * argument found */
1393 lr=1;
748a9306 1394 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
4633a7c4 1395 && (cvp=ocvp) && (lr = -1))
a0d0e21e
LW
1396 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1397 && !(flags & AMGf_unary)) {
1398 /* We look for substitution for
1399 * comparison operations and
fc36a67e 1400 * concatenation */
a0d0e21e
LW
1401 if (method==concat_amg || method==concat_ass_amg
1402 || method==repeat_amg || method==repeat_ass_amg) {
1403 return NULL; /* Delegate operation to string conversion */
1404 }
1405 off = -1;
1406 switch (method) {
1407 case lt_amg:
1408 case le_amg:
1409 case gt_amg:
1410 case ge_amg:
1411 case eq_amg:
1412 case ne_amg:
1413 postpr = 1; off=ncmp_amg; break;
1414 case slt_amg:
1415 case sle_amg:
1416 case sgt_amg:
1417 case sge_amg:
1418 case seq_amg:
1419 case sne_amg:
1420 postpr = 1; off=scmp_amg; break;
1421 }
1422 if (off != -1) cv = cvp[off];
1423 if (!cv) {
1424 goto not_found;
1425 }
1426 } else {
a6006777 1427 not_found: /* No method found, either report or croak */
a0d0e21e
LW
1428 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1429 notfound = 1; lr = -1;
1430 } else if (cvp && (cv=cvp[nomethod_amg])) {
1431 notfound = 1; lr = 1;
1432 } else {
46fc3d4c 1433 SV *msg;
774d564b 1434 if (off==-1) off=method;
cea2e8a9 1435 msg = sv_2mortal(Perl_newSVpvf(aTHX_
46fc3d4c 1436 "Operation `%s': no method found,%sargument %s%s%s%s",
22c35a8c 1437 PL_AMG_names[method + assignshift],
e7ea3e70 1438 (flags & AMGf_unary ? " " : "\n\tleft "),
a0d0e21e
LW
1439 SvAMAGIC(left)?
1440 "in overloaded package ":
1441 "has no overloaded magic",
1442 SvAMAGIC(left)?
1443 HvNAME(SvSTASH(SvRV(left))):
1444 "",
1445 SvAMAGIC(right)?
e7ea3e70
IZ
1446 ",\n\tright argument in overloaded package ":
1447 (flags & AMGf_unary
1448 ? ""
1449 : ",\n\tright argument has no overloaded magic"),
a0d0e21e
LW
1450 SvAMAGIC(right)?
1451 HvNAME(SvSTASH(SvRV(right))):
46fc3d4c 1452 ""));
a0d0e21e 1453 if (amtp && amtp->fallback >= AMGfallYES) {
cea2e8a9 1454 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
a0d0e21e 1455 } else {
894356b3 1456 Perl_croak(aTHX_ "%"SVf, msg);
a0d0e21e
LW
1457 }
1458 return NULL;
1459 }
ee239bfe 1460 force_cpy = force_cpy || assign;
a0d0e21e
LW
1461 }
1462 }
1463 if (!notfound) {
cea2e8a9 1464 DEBUG_o( Perl_deb(aTHX_
46fc3d4c 1465 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
22c35a8c 1466 PL_AMG_names[off],
748a9306
LW
1467 method+assignshift==off? "" :
1468 " (initially `",
1469 method+assignshift==off? "" :
22c35a8c 1470 PL_AMG_names[method+assignshift],
748a9306
LW
1471 method+assignshift==off? "" : "')",
1472 flags & AMGf_unary? "" :
1473 lr==1 ? " for right argument": " for left argument",
1474 flags & AMGf_unary? " for argument" : "",
a0d0e21e
LW
1475 HvNAME(stash),
1476 fl? ",\n\tassignment variant used": "") );
ee239bfe 1477 }
748a9306
LW
1478 /* Since we use shallow copy during assignment, we need
1479 * to dublicate the contents, probably calling user-supplied
1480 * version of copy operator
1481 */
ee239bfe
IZ
1482 /* We need to copy in following cases:
1483 * a) Assignment form was called.
1484 * assignshift==1, assign==T, method + 1 == off
1485 * b) Increment or decrement, called directly.
1486 * assignshift==0, assign==0, method + 0 == off
1487 * c) Increment or decrement, translated to assignment add/subtr.
1488 * assignshift==0, assign==T,
1489 * force_cpy == T
1490 * d) Increment or decrement, translated to nomethod.
1491 * assignshift==0, assign==0,
1492 * force_cpy == T
1493 * e) Assignment form translated to nomethod.
1494 * assignshift==1, assign==T, method + 1 != off
1495 * force_cpy == T
1496 */
1497 /* off is method, method+assignshift, or a result of opcode substitution.
1498 * In the latter case assignshift==0, so only notfound case is important.
1499 */
1500 if (( (method + assignshift == off)
1501 && (assign || (method == inc_amg) || (method == dec_amg)))
1502 || force_cpy)
1503 RvDEEPCP(left);
a0d0e21e
LW
1504 {
1505 dSP;
1506 BINOP myop;
1507 SV* res;
54310121 1508 bool oldcatch = CATCH_GET;
a0d0e21e 1509
54310121 1510 CATCH_SET(TRUE);
a0d0e21e
LW
1511 Zero(&myop, 1, BINOP);
1512 myop.op_last = (OP *) &myop;
1513 myop.op_next = Nullop;
54310121 1514 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
a0d0e21e 1515
e788e7d3 1516 PUSHSTACKi(PERLSI_OVERLOAD);
a0d0e21e 1517 ENTER;
462e5cf6 1518 SAVEOP();
533c011a 1519 PL_op = (OP *) &myop;
3280af22 1520 if (PERLDB_SUB && PL_curstash != PL_debstash)
533c011a 1521 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 1522 PUTBACK;
cea2e8a9 1523 pp_pushmark();
a0d0e21e 1524
924508f0 1525 EXTEND(SP, notfound + 5);
a0d0e21e
LW
1526 PUSHs(lr>0? right: left);
1527 PUSHs(lr>0? left: right);
3280af22 1528 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
a0d0e21e 1529 if (notfound) {
22c35a8c 1530 PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
a0d0e21e
LW
1531 }
1532 PUSHs((SV*)cv);
1533 PUTBACK;
1534
155aba94 1535 if ((PL_op = Perl_pp_entersub(aTHX)))
cea2e8a9 1536 CALLRUNOPS(aTHX);
a0d0e21e
LW
1537 LEAVE;
1538 SPAGAIN;
1539
1540 res=POPs;
ebafeae7 1541 PUTBACK;
d3acc0f7 1542 POPSTACK;
54310121 1543 CATCH_SET(oldcatch);
a0d0e21e 1544
a0d0e21e
LW
1545 if (postpr) {
1546 int ans;
1547 switch (method) {
1548 case le_amg:
1549 case sle_amg:
1550 ans=SvIV(res)<=0; break;
1551 case lt_amg:
1552 case slt_amg:
1553 ans=SvIV(res)<0; break;
1554 case ge_amg:
1555 case sge_amg:
1556 ans=SvIV(res)>=0; break;
1557 case gt_amg:
1558 case sgt_amg:
1559 ans=SvIV(res)>0; break;
1560 case eq_amg:
1561 case seq_amg:
1562 ans=SvIV(res)==0; break;
1563 case ne_amg:
1564 case sne_amg:
1565 ans=SvIV(res)!=0; break;
1566 case inc_amg:
1567 case dec_amg:
bbce6d69 1568 SvSetSV(left,res); return left;
dc437b57 1569 case not_amg:
fe7ac86a 1570 ans=!SvTRUE(res); break;
a0d0e21e 1571 }
54310121 1572 return boolSV(ans);
748a9306
LW
1573 } else if (method==copy_amg) {
1574 if (!SvROK(res)) {
cea2e8a9 1575 Perl_croak(aTHX_ "Copy method did not return a reference");
748a9306
LW
1576 }
1577 return SvREFCNT_inc(SvRV(res));
a0d0e21e
LW
1578 } else {
1579 return res;
1580 }
1581 }
1582}