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