This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
implement -follow option in find2perl (from Helmut Jarausch
[perl5.git] / gv.c
CommitLineData
a0d0e21e 1/* gv.c
79072805 2 *
4eb8286e 3 * Copyright (c) 1991-1999, 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
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
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);
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
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
dc437b57 268 if (lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE)) {
44a8e56a
PP
269 if (gv = gv_fetchmeth(lastchance, name, len,
270 (level >= 0) ? level + 1 : level - 1)) {
271 gotcha:
dc848c6f
PP
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
PP
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
LW
287 return gv;
288 }
005a453c
JP
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
LW
293 }
294 }
295
79072805
LW
296 return 0;
297}
298
954c1994
GS
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
PP
310 return gv_fetchmethod_autoload(stash, name, TRUE);
311}
312
954c1994
GS
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
GS
345 register const char *nend;
346 const char *nsplit = 0;
a0d0e21e 347 GV* gv;
463ee0b2
LW
348
349 for (nend = name; *nend; nend++) {
9607fc9c 350 if (*nend == '\'')
a0d0e21e 351 nsplit = nend;
9607fc9c
PP
352 else if (*nend == ':' && *(nend + 1) == ':')
353 nsplit = ++nend;
a0d0e21e
LW
354 }
355 if (nsplit) {
08105a92 356 const char *origname = name;
a0d0e21e 357 name = nsplit + 1;
a0d0e21e
LW
358 if (*nsplit == ':')
359 --nsplit;
9607fc9c
PP
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",
1d7c1841 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
PP
368 else
369 stash = gv_stashpvn(origname, nsplit - origname, TRUE);
4633a7c4
LW
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
PP
379 else if (autoload) {
380 CV* cv = GvCV(gv);
09280a33
CS
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
PP
394 if (autogv)
395 gv = autogv;
396 }
397 }
44a8e56a
PP
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
PP
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
PP
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
PM
423 if (ckWARN(WARN_DEPRECATED) && !method &&
424 (GvCVGEN(gv) || GvSTASH(gv) != stash))
cea2e8a9 425 Perl_warner(aTHX_ WARN_DEPRECATED,
dc848c6f
PP
426 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
427 HvNAME(stash), (int)len, name);
44a8e56a
PP
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
LW
444 return gv;
445}
446
954c1994
GS
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
PP
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
PP
467 char smallbuf[256];
468 char *tmpbuf;
a0d0e21e
LW
469 HV *stash;
470 GV *tmpgv;
dc437b57 471
46fc3d4c
PP
472 if (namelen + 3 < sizeof smallbuf)
473 tmpbuf = smallbuf;
474 else
475 New(606, tmpbuf, namelen + 3, char);
dc437b57
PP
476 Copy(name,tmpbuf,namelen,char);
477 tmpbuf[namelen++] = ':';
478 tmpbuf[namelen++] = ':';
479 tmpbuf[namelen] = '\0';
46fc3d4c
PP
480 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
481 if (tmpbuf != smallbuf)
482 Safefree(tmpbuf);
a0d0e21e
LW
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
LW
491}
492
954c1994
GS
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
PP
505 register char *ptr;
506 STRLEN len;
507 ptr = SvPV(sv,len);
508 return gv_stashpvn(ptr, len, create);
a0d0e21e
LW
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
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) {
b86a2fa7
GS
584 if (isIDFIRST(*name)
585 || (IN_UTF8 && ((*name & 0xc0) == 0xc0) && isIDFIRST_utf8((U8*)name)))
586 {
9607fc9c
PP
587 bool global = FALSE;
588
463ee0b2 589 if (isUPPER(*name)) {
9d116dd7
JH
590 if (*name == 'S' && (
591 strEQ(name, "SIG") ||
592 strEQ(name, "STDIN") ||
593 strEQ(name, "STDOUT") ||
594 strEQ(name, "STDERR")))
595 global = TRUE;
596 else if (*name == 'I' && strEQ(name, "INC"))
597 global = TRUE;
598 else if (*name == 'E' && strEQ(name, "ENV"))
599 global = TRUE;
463ee0b2
LW
600 else if (*name == 'A' && (
601 strEQ(name, "ARGV") ||
9d116dd7 602 strEQ(name, "ARGVOUT")))
463ee0b2
LW
603 global = TRUE;
604 }
605 else if (*name == '_' && !name[1])
606 global = TRUE;
9607fc9c 607
463ee0b2 608 if (global)
3280af22
NIS
609 stash = PL_defstash;
610 else if ((COP*)PL_curcop == &PL_compiling) {
611 stash = PL_curstash;
612 if (add && (PL_hints & HINT_STRICT_VARS) &&
748a9306
LW
613 sv_type != SVt_PVCV &&
614 sv_type != SVt_PVGV &&
4633a7c4 615 sv_type != SVt_PVFM &&
c07a80fd 616 sv_type != SVt_PVIO &&
377b8fbc 617 !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
748a9306 618 {
4633a7c4
LW
619 gvp = (GV**)hv_fetch(stash,name,len,0);
620 if (!gvp ||
3280af22 621 *gvp == (GV*)&PL_sv_undef ||
a5f75d66
AD
622 SvTYPE(*gvp) != SVt_PVGV)
623 {
4633a7c4 624 stash = 0;
a5f75d66
AD
625 }
626 else if (sv_type == SVt_PV && !GvIMPORTED_SV(*gvp) ||
627 sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp) ||
628 sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp) )
4633a7c4 629 {
cea2e8a9 630 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
4633a7c4
LW
631 sv_type == SVt_PVAV ? '@' :
632 sv_type == SVt_PVHV ? '%' : '$',
633 name);
8ebc5c01 634 if (GvCVu(*gvp))
cea2e8a9 635 Perl_warn(aTHX_ "(Did you mean &%s instead?)\n", name);
a0d0e21e 636 stash = 0;
4633a7c4 637 }
a0d0e21e 638 }
85e6fe83 639 }
463ee0b2 640 else
1d7c1841 641 stash = CopSTASH(PL_curcop);
463ee0b2
LW
642 }
643 else
3280af22 644 stash = PL_defstash;
463ee0b2
LW
645 }
646
647 /* By this point we should have a stash and a name */
648
a0d0e21e 649 if (!stash) {
5a844595
GS
650 if (add) {
651 qerror(Perl_mess(aTHX_
652 "Global symbol \"%s%s\" requires explicit package name",
653 (sv_type == SVt_PV ? "$"
654 : sv_type == SVt_PVAV ? "@"
655 : sv_type == SVt_PVHV ? "%"
656 : ""), name));
a0d0e21e 657 }
5a844595 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);
9607fc9c 684 GvFLAGS(gv) |= add_gvflags;
93a17b20 685
0453d815
PM
686 if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE))
687 GvMULTI_on(gv) ;
688
93a17b20
LW
689 /* set up magic where warranted */
690 switch (*name) {
a0d0e21e
LW
691 case 'A':
692 if (strEQ(name, "ARGV")) {
693 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
694 }
695 break;
a0d0e21e
LW
696 case 'E':
697 if (strnEQ(name, "EXPORT", 6))
a5f75d66 698 GvMULTI_on(gv);
a0d0e21e 699 break;
463ee0b2
LW
700 case 'I':
701 if (strEQ(name, "ISA")) {
702 AV* av = GvAVn(gv);
a5f75d66 703 GvMULTI_on(gv);
a0d0e21e 704 sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
93965878 705 /* NOTE: No support for tied ISA */
55d729e4
GS
706 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
707 && AvFILLp(av) == -1)
85e6fe83 708 {
a0d0e21e 709 char *pname;
79cb57f6 710 av_push(av, newSVpvn(pname = "NDBM_File",9));
dc437b57 711 gv_stashpvn(pname, 9, TRUE);
79cb57f6 712 av_push(av, newSVpvn(pname = "DB_File",7));
dc437b57 713 gv_stashpvn(pname, 7, TRUE);
79cb57f6 714 av_push(av, newSVpvn(pname = "GDBM_File",9));
dc437b57 715 gv_stashpvn(pname, 9, TRUE);
79cb57f6 716 av_push(av, newSVpvn(pname = "SDBM_File",9));
dc437b57 717 gv_stashpvn(pname, 9, TRUE);
79cb57f6 718 av_push(av, newSVpvn(pname = "ODBM_File",9));
dc437b57 719 gv_stashpvn(pname, 9, TRUE);
85e6fe83 720 }
463ee0b2
LW
721 }
722 break;
a0d0e21e
LW
723 case 'O':
724 if (strEQ(name, "OVERLOAD")) {
725 HV* hv = GvHVn(gv);
a5f75d66 726 GvMULTI_on(gv);
ea0efc06 727 hv_magic(hv, gv, 'A');
a0d0e21e
LW
728 }
729 break;
93a17b20
LW
730 case 'S':
731 if (strEQ(name, "SIG")) {
732 HV *hv;
dc437b57 733 I32 i;
1d7c1841
GS
734 if (!PL_psig_ptr) {
735 int sig_num[] = { SIG_NUM };
736 New(73, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
737 New(73, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
738 }
739 GvMULTI_on(gv);
740 hv = GvHVn(gv);
741 hv_magic(hv, gv, 'S');
742 for (i = 1; PL_sig_name[i]; i++) {
dc437b57 743 SV ** init;
1d7c1841
GS
744 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
745 if (init)
746 sv_setsv(*init, &PL_sv_undef);
22c35a8c
GS
747 PL_psig_ptr[i] = 0;
748 PL_psig_name[i] = 0;
dc437b57 749 }
93a17b20
LW
750 }
751 break;
09bef843
SB
752 case 'V':
753 if (strEQ(name, "VERSION"))
754 GvMULTI_on(gv);
755 break;
93a17b20
LW
756
757 case '&':
463ee0b2
LW
758 if (len > 1)
759 break;
3280af22 760 PL_sawampersand = TRUE;
a0d0e21e 761 goto ro_magicalize;
93a17b20
LW
762
763 case '`':
463ee0b2
LW
764 if (len > 1)
765 break;
3280af22 766 PL_sawampersand = TRUE;
a0d0e21e 767 goto ro_magicalize;
93a17b20
LW
768
769 case '\'':
463ee0b2
LW
770 if (len > 1)
771 break;
3280af22 772 PL_sawampersand = TRUE;
a0d0e21e 773 goto ro_magicalize;
93a17b20
LW
774
775 case ':':
463ee0b2
LW
776 if (len > 1)
777 break;
3280af22 778 sv_setpv(GvSV(gv),PL_chopset);
93a17b20
LW
779 goto magicalize;
780
ff0cee69
PP
781 case '?':
782 if (len > 1)
783 break;
784#ifdef COMPLEX_STATUS
07f14f54 785 (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
ff0cee69
PP
786#endif
787 goto magicalize;
788
067391ea 789 case '!':
4318d5a0 790 if (len > 1)
067391ea 791 break;
3280af22 792 if (sv_type > SVt_PV && PL_curcop != &PL_compiling) {
067391ea 793 HV* stash = gv_stashpvn("Errno",5,FALSE);
265f5c4a 794 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
067391ea
GS
795 dSP;
796 PUTBACK;
cea2e8a9 797 require_pv("Errno.pm");
067391ea
GS
798 SPAGAIN;
799 stash = gv_stashpvn("Errno",5,FALSE);
800 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
cea2e8a9 801 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
067391ea
GS
802 }
803 }
804 goto magicalize;
6cef1e77
IZ
805 case '-':
806 if (len > 1)
807 break;
808 else {
809 AV* av = GvAVn(gv);
810 sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
811 }
812 goto magicalize;
93a17b20 813 case '#':
a0d0e21e 814 case '*':
599cee73 815 if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
cea2e8a9 816 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
a0d0e21e
LW
817 /* FALL THROUGH */
818 case '[':
93a17b20
LW
819 case '^':
820 case '~':
821 case '=':
93a17b20
LW
822 case '%':
823 case '.':
93a17b20
LW
824 case '(':
825 case ')':
826 case '<':
827 case '>':
828 case ',':
829 case '\\':
830 case '/':
93a17b20 831 case '|':
748a9306 832 case '\001':
49460fe6 833 case '\003':
93a17b20 834 case '\004':
ad8898e0 835 case '\005':
748a9306 836 case '\006':
a0d0e21e 837 case '\010':
9d116dd7 838 case '\011': /* NOT \t in EBCDIC */
ad8898e0 839 case '\017':
93a17b20
LW
840 case '\020':
841 case '\024':
463ee0b2
LW
842 if (len > 1)
843 break;
844 goto magicalize;
6cef1e77
IZ
845 case '\023':
846 if (len > 1)
847 break;
848 goto ro_magicalize;
4438c4b7
JH
849 case '\027': /* $^W & $^Warnings */
850 if (len > 1 && strNE(name, "\027arnings"))
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
877 case '\014':
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;
79072805 898 }
93a17b20 899 return gv;
79072805
LW
900}
901
902void
864dbfa3 903Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
79072805
LW
904{
905 HV *hv = GvSTASH(gv);
f967eb5f
PP
906 if (!hv) {
907 SvOK_off(sv);
79072805 908 return;
f967eb5f
PP
909 }
910 sv_setpv(sv, prefix ? prefix : "");
79072805 911 sv_catpv(sv,HvNAME(hv));
463ee0b2 912 sv_catpvn(sv,"::", 2);
79072805
LW
913 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
914}
915
916void
864dbfa3 917Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
79072805 918{
f967eb5f 919 GV *egv = GvEGV(gv);
748a9306
LW
920 if (!egv)
921 egv = gv;
f6aff53a
PP
922 gv_fullname3(sv, egv, prefix);
923}
924
925/* XXX compatibility with versions <= 5.003. */
926void
864dbfa3 927Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
f6aff53a
PP
928{
929 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
930}
931
932/* XXX compatibility with versions <= 5.003. */
933void
864dbfa3 934Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
f6aff53a
PP
935{
936 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
79072805
LW
937}
938
939IO *
864dbfa3 940Perl_newIO(pTHX)
79072805 941{
11343788 942 dTHR;
79072805 943 IO *io;
8990e307
LW
944 GV *iogv;
945
946 io = (IO*)NEWSV(0,0);
a0d0e21e 947 sv_upgrade((SV *)io,SVt_PVIO);
8990e307
LW
948 SvREFCNT(io) = 1;
949 SvOBJECT_on(io);
c9de509e 950 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
5f2d631d
GS
951 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
952 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
c9de509e 953 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
8990e307 954 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
79072805
LW
955 return io;
956}
957
958void
864dbfa3 959Perl_gv_check(pTHX_ HV *stash)
79072805 960{
11343788 961 dTHR;
79072805
LW
962 register HE *entry;
963 register I32 i;
964 register GV *gv;
463ee0b2
LW
965 HV *hv;
966
8990e307
LW
967 if (!HvARRAY(stash))
968 return;
a0d0e21e 969 for (i = 0; i <= (I32) HvMAX(stash); i++) {
dc437b57
PP
970 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
971 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
972 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
a0d0e21e 973 {
19b6c847 974 if (hv != PL_defstash && hv != stash)
a0d0e21e
LW
975 gv_check(hv); /* nested package */
976 }
dc437b57 977 else if (isALPHA(*HeKEY(entry))) {
1d7c1841 978 char *file;
dc437b57 979 gv = (GV*)HeVAL(entry);
55d729e4 980 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
463ee0b2 981 continue;
1d7c1841
GS
982 file = GvFILE(gv);
983 /* performance hack: if filename is absolute and it's a standard
984 * module, don't bother warning */
985 if (file
986 && PERL_FILE_IS_ABSOLUTE(file)
987 && (instr(file, "/lib/") || instr(file, ".pm")))
988 {
8990e307 989 continue;
1d7c1841
GS
990 }
991 CopLINE_set(PL_curcop, GvLINE(gv));
992#ifdef USE_ITHREADS
993 CopFILE(PL_curcop) = file; /* set for warning */
994#else
995 CopFILEGV(PL_curcop) = gv_fetchfile(file);
996#endif
cea2e8a9 997 Perl_warner(aTHX_ WARN_ONCE,
599cee73 998 "Name \"%s::%s\" used only once: possible typo",
a0d0e21e 999 HvNAME(stash), GvNAME(gv));
463ee0b2 1000 }
79072805
LW
1001 }
1002 }
1003}
1004
1005GV *
864dbfa3 1006Perl_newGVgen(pTHX_ char *pack)
79072805 1007{
cea2e8a9 1008 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
46fc3d4c 1009 TRUE, SVt_PVGV);
79072805
LW
1010}
1011
1012/* hopefully this is only called on local symbol table entries */
1013
1014GP*
864dbfa3 1015Perl_gp_ref(pTHX_ GP *gp)
79072805 1016{
1d7c1841
GS
1017 if (!gp)
1018 return (GP*)NULL;
79072805 1019 gp->gp_refcnt++;
44a8e56a
PP
1020 if (gp->gp_cv) {
1021 if (gp->gp_cvgen) {
1022 /* multi-named GPs cannot be used for method cache */
1023 SvREFCNT_dec(gp->gp_cv);
1024 gp->gp_cv = Nullcv;
1025 gp->gp_cvgen = 0;
1026 }
1027 else {
1028 /* Adding a new name to a subroutine invalidates method cache */
3280af22 1029 PL_sub_generation++;
44a8e56a
PP
1030 }
1031 }
79072805 1032 return gp;
79072805
LW
1033}
1034
1035void
864dbfa3 1036Perl_gp_free(pTHX_ GV *gv)
79072805 1037{
f248d071 1038 dTHR;
79072805 1039 GP* gp;
377b8fbc 1040 CV* cv;
79072805
LW
1041
1042 if (!gv || !(gp = GvGP(gv)))
1043 return;
f248d071
GS
1044 if (gp->gp_refcnt == 0) {
1045 if (ckWARN_d(WARN_INTERNAL))
1046 Perl_warner(aTHX_ WARN_INTERNAL,
1047 "Attempt to free unreferenced glob pointers");
79072805
LW
1048 return;
1049 }
44a8e56a
PP
1050 if (gp->gp_cv) {
1051 /* Deleting the name of a subroutine invalidates method cache */
3280af22 1052 PL_sub_generation++;
44a8e56a 1053 }
748a9306
LW
1054 if (--gp->gp_refcnt > 0) {
1055 if (gp->gp_egv == gv)
1056 gp->gp_egv = 0;
79072805 1057 return;
748a9306 1058 }
79072805 1059
8990e307
LW
1060 SvREFCNT_dec(gp->gp_sv);
1061 SvREFCNT_dec(gp->gp_av);
1062 SvREFCNT_dec(gp->gp_hv);
377b8fbc 1063 SvREFCNT_dec(gp->gp_io);
a6006777 1064 SvREFCNT_dec(gp->gp_cv);
748a9306
LW
1065 SvREFCNT_dec(gp->gp_form);
1066
79072805
LW
1067 Safefree(gp);
1068 GvGP(gv) = 0;
1069}
1070
1071#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1072#define MICROPORT
1073#endif
1074
1075#ifdef MICROPORT /* Microport 2.4 hack */
1076AV *GvAVn(gv)
1077register GV *gv;
1078{
1079 if (GvGP(gv)->gp_av)
1080 return GvGP(gv)->gp_av;
1081 else
1082 return GvGP(gv_AVadd(gv))->gp_av;
1083}
1084
1085HV *GvHVn(gv)
1086register GV *gv;
1087{
1088 if (GvGP(gv)->gp_hv)
1089 return GvGP(gv)->gp_hv;
1090 else
1091 return GvGP(gv_HVadd(gv))->gp_hv;
1092}
1093#endif /* Microport 2.4 hack */
a0d0e21e 1094
a0d0e21e
LW
1095/* Updates and caches the CV's */
1096
1097bool
864dbfa3 1098Perl_Gv_AMupdate(pTHX_ HV *stash)
a0d0e21e 1099{
11343788 1100 dTHR;
a0d0e21e
LW
1101 GV** gvp;
1102 HV* hv;
1103 GV* gv;
1104 CV* cv;
1105 MAGIC* mg=mg_find((SV*)stash,'c');
8ac85365 1106 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
a6006777 1107 AMT amt;
2d8e6c8d 1108 STRLEN n_a;
a0d0e21e 1109
3280af22
NIS
1110 if (mg && amtp->was_ok_am == PL_amagic_generation
1111 && amtp->was_ok_sub == PL_sub_generation)
a6006777
PP
1112 return AMT_AMAGIC(amtp);
1113 if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */
748a9306 1114 int i;
a6006777 1115 for (i=1; i<NofAMmeth; i++) {
748a9306
LW
1116 if (amtp->table[i]) {
1117 SvREFCNT_dec(amtp->table[i]);
1118 }
1119 }
1120 }
a0d0e21e
LW
1121 sv_unmagic((SV*)stash, 'c');
1122
cea2e8a9 1123 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
a0d0e21e 1124
3280af22
NIS
1125 amt.was_ok_am = PL_amagic_generation;
1126 amt.was_ok_sub = PL_sub_generation;
a6006777
PP
1127 amt.fallback = AMGfallNO;
1128 amt.flags = 0;
1129
1130#ifdef OVERLOAD_VIA_HASH
1131 gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
3280af22 1132 if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
a0d0e21e
LW
1133 int filled=0;
1134 int i;
1135 char *cp;
a0d0e21e
LW
1136 SV* sv;
1137 SV** svp;
a0d0e21e 1138
22c35a8c 1139 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
a0d0e21e 1140
22c35a8c 1141 if (( cp = (char *)PL_AMG_names[0] ) &&
a6006777 1142 (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
a0d0e21e
LW
1143 if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1144 else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1145 }
a6006777
PP
1146 for (i = 1; i < NofAMmeth; i++) {
1147 cv = 0;
22c35a8c 1148 cp = (char *)PL_AMG_names[i];
a6006777
PP
1149
1150 svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
3280af22 1151 if (svp && ((sv = *svp) != &PL_sv_undef)) {
a0d0e21e
LW
1152 switch (SvTYPE(sv)) {
1153 default:
1154 if (!SvROK(sv)) {
1155 if (!SvOK(sv)) break;
2d8e6c8d 1156 gv = gv_fetchmethod(stash, SvPV(sv, n_a));
a0d0e21e
LW
1157 if (gv) cv = GvCV(gv);
1158 break;
1159 }
1160 cv = (CV*)SvRV(sv);
1161 if (SvTYPE(cv) == SVt_PVCV)
1162 break;
1163 /* FALL THROUGH */
1164 case SVt_PVHV:
1165 case SVt_PVAV:
cea2e8a9 1166 Perl_croak(aTHX_ "Not a subroutine reference in overload table");
a0d0e21e
LW
1167 return FALSE;
1168 case SVt_PVCV:
8ebc5c01
PP
1169 cv = (CV*)sv;
1170 break;
a0d0e21e 1171 case SVt_PVGV:
8ebc5c01 1172 if (!(cv = GvCVu((GV*)sv)))
f6ec51f7 1173 cv = sv_2cv(sv, &stash, &gv, FALSE);
8ebc5c01 1174 break;
a0d0e21e
LW
1175 }
1176 if (cv) filled=1;
1177 else {
cea2e8a9 1178 Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
a0d0e21e
LW
1179 cp,HvNAME(stash));
1180 return FALSE;
1181 }
1182 }
a6006777
PP
1183#else
1184 {
1185 int filled = 0;
1186 int i;
9607fc9c 1187 const char *cp;
a6006777
PP
1188 SV* sv = NULL;
1189 SV** svp;
1190
22c35a8c 1191 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
a6006777 1192
22c35a8c 1193 if ( cp = PL_AMG_names[0] ) {
a6006777 1194 /* Try to find via inheritance. */
774d564b 1195 gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
a6006777
PP
1196 if (gv) sv = GvSV(gv);
1197
774d564b 1198 if (!gv) goto no_table;
a6006777
PP
1199 else if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1200 else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1201 }
1202
1203 for (i = 1; i < NofAMmeth; i++) {
cea2e8a9
GS
1204 SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
1205 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
44a8e56a 1206 cp, HvNAME(stash)) );
46fc3d4c
PP
1207 /* don't fill the cache while looking up! */
1208 gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
1209 cv = 0;
44a8e56a 1210 if(gv && (cv = GvCV(gv))) {
44a8e56a
PP
1211 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1212 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1213 /* GvSV contains the name of the method. */
1214 GV *ngv;
1215
cea2e8a9 1216 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
2d8e6c8d 1217 SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
dc848c6f
PP
1218 if (!SvPOK(GvSV(gv))
1219 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1220 FALSE)))
1221 {
44a8e56a
PP
1222 /* Can be an import stub (created by `can'). */
1223 if (GvCVGEN(gv)) {
cea2e8a9 1224 Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
44a8e56a
PP
1225 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1226 cp, HvNAME(stash));
1227 } else
cea2e8a9 1228 Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
44a8e56a
PP
1229 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1230 cp, HvNAME(stash));
1231 }
dc848c6f 1232 cv = GvCV(gv = ngv);
44a8e56a 1233 }
cea2e8a9 1234 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
44a8e56a
PP
1235 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1236 GvNAME(CvGV(cv))) );
1237 filled = 1;
1238 }
a6006777
PP
1239#endif
1240 amt.table[i]=(CV*)SvREFCNT_inc(cv);
a0d0e21e 1241 }
a0d0e21e 1242 if (filled) {
a6006777
PP
1243 AMT_AMAGIC_on(&amt);
1244 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
a0d0e21e
LW
1245 return TRUE;
1246 }
1247 }
a6006777 1248 /* Here we have no table: */
774d564b 1249 no_table:
a6006777
PP
1250 AMT_AMAGIC_off(&amt);
1251 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
a0d0e21e
LW
1252 return FALSE;
1253}
1254
a0d0e21e 1255SV*
864dbfa3 1256Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
a0d0e21e 1257{
11343788 1258 dTHR;
a0d0e21e
LW
1259 MAGIC *mg;
1260 CV *cv;
1261 CV **cvp=NULL, **ocvp=NULL;
1262 AMT *amtp, *oamtp;
1263 int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
ee239bfe 1264 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
a0d0e21e
LW
1265 HV* stash;
1266 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1267 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
a6006777
PP
1268 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1269 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
8ac85365 1270 : (CV **) NULL))
748a9306
LW
1271 && ((cv = cvp[off=method+assignshift])
1272 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1273 * usual method */
1274 (fl = 1, cv = cvp[off=method])))) {
a0d0e21e
LW
1275 lr = -1; /* Call method for left argument */
1276 } else {
1277 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1278 int logic;
1279
1280 /* look for substituted methods */
ee239bfe 1281 /* In all the covered cases we should be called with assign==0. */
a0d0e21e
LW
1282 switch (method) {
1283 case inc_amg:
ee239bfe
IZ
1284 force_cpy = 1;
1285 if ((cv = cvp[off=add_ass_amg])
1286 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3280af22 1287 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1288 }
1289 break;
1290 case dec_amg:
ee239bfe
IZ
1291 force_cpy = 1;
1292 if ((cv = cvp[off = subtr_ass_amg])
1293 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3280af22 1294 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1295 }
1296 break;
1297 case bool__amg:
1298 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1299 break;
1300 case numer_amg:
1301 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1302 break;
1303 case string_amg:
1304 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1305 break;
dc437b57
PP
1306 case not_amg:
1307 (void)((cv = cvp[off=bool__amg])
1308 || (cv = cvp[off=numer_amg])
1309 || (cv = cvp[off=string_amg]));
1310 postpr = 1;
1311 break;
748a9306
LW
1312 case copy_amg:
1313 {
76e3520e
GS
1314 /*
1315 * SV* ref causes confusion with the interpreter variable of
1316 * the same name
1317 */
1318 SV* tmpRef=SvRV(left);
1319 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
fc36a67e
PP
1320 /*
1321 * Just to be extra cautious. Maybe in some
1322 * additional cases sv_setsv is safe, too.
1323 */
76e3520e 1324 SV* newref = newSVsv(tmpRef);
748a9306 1325 SvOBJECT_on(newref);
76e3520e 1326 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
748a9306
LW
1327 return newref;
1328 }
1329 }
1330 break;
a0d0e21e 1331 case abs_amg:
748a9306 1332 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
a0d0e21e 1333 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
748a9306 1334 SV* nullsv=sv_2mortal(newSViv(0));
a0d0e21e 1335 if (off1==lt_amg) {
748a9306 1336 SV* lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1337 lt_amg,AMGf_noright);
1338 logic = SvTRUE(lessp);
1339 } else {
748a9306 1340 SV* lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1341 ncmp_amg,AMGf_noright);
1342 logic = (SvNV(lessp) < 0);
1343 }
1344 if (logic) {
1345 if (off==subtr_amg) {
1346 right = left;
748a9306 1347 left = nullsv;
a0d0e21e
LW
1348 lr = 1;
1349 }
1350 } else {
1351 return left;
1352 }
1353 }
1354 break;
1355 case neg_amg:
1356 if (cv = cvp[off=subtr_amg]) {
1357 right = left;
1358 left = sv_2mortal(newSViv(0));
1359 lr = 1;
1360 }
1361 break;
f5284f61
IZ
1362 case iter_amg: /* XXXX Eventually should do to_gv. */
1363 case to_sv_amg:
1364 case to_av_amg:
1365 case to_hv_amg:
1366 case to_gv_amg:
1367 case to_cv_amg:
1368 /* FAIL safe */
1369 return NULL; /* Delegate operation to standard mechanisms. */
1370 break;
a0d0e21e
LW
1371 default:
1372 goto not_found;
1373 }
1374 if (!cv) goto not_found;
1375 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1376 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
a6006777
PP
1377 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1378 ? (amtp = (AMT*)mg->mg_ptr)->table
8ac85365 1379 : (CV **) NULL))
a0d0e21e
LW
1380 && (cv = cvp[off=method])) { /* Method for right
1381 * argument found */
1382 lr=1;
748a9306 1383 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
4633a7c4 1384 && (cvp=ocvp) && (lr = -1))
a0d0e21e
LW
1385 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1386 && !(flags & AMGf_unary)) {
1387 /* We look for substitution for
1388 * comparison operations and
fc36a67e 1389 * concatenation */
a0d0e21e
LW
1390 if (method==concat_amg || method==concat_ass_amg
1391 || method==repeat_amg || method==repeat_ass_amg) {
1392 return NULL; /* Delegate operation to string conversion */
1393 }
1394 off = -1;
1395 switch (method) {
1396 case lt_amg:
1397 case le_amg:
1398 case gt_amg:
1399 case ge_amg:
1400 case eq_amg:
1401 case ne_amg:
1402 postpr = 1; off=ncmp_amg; break;
1403 case slt_amg:
1404 case sle_amg:
1405 case sgt_amg:
1406 case sge_amg:
1407 case seq_amg:
1408 case sne_amg:
1409 postpr = 1; off=scmp_amg; break;
1410 }
1411 if (off != -1) cv = cvp[off];
1412 if (!cv) {
1413 goto not_found;
1414 }
1415 } else {
a6006777 1416 not_found: /* No method found, either report or croak */
a0d0e21e
LW
1417 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1418 notfound = 1; lr = -1;
1419 } else if (cvp && (cv=cvp[nomethod_amg])) {
1420 notfound = 1; lr = 1;
1421 } else {
46fc3d4c 1422 SV *msg;
774d564b 1423 if (off==-1) off=method;
cea2e8a9 1424 msg = sv_2mortal(Perl_newSVpvf(aTHX_
46fc3d4c 1425 "Operation `%s': no method found,%sargument %s%s%s%s",
22c35a8c 1426 PL_AMG_names[method + assignshift],
e7ea3e70 1427 (flags & AMGf_unary ? " " : "\n\tleft "),
a0d0e21e
LW
1428 SvAMAGIC(left)?
1429 "in overloaded package ":
1430 "has no overloaded magic",
1431 SvAMAGIC(left)?
1432 HvNAME(SvSTASH(SvRV(left))):
1433 "",
1434 SvAMAGIC(right)?
e7ea3e70
IZ
1435 ",\n\tright argument in overloaded package ":
1436 (flags & AMGf_unary
1437 ? ""
1438 : ",\n\tright argument has no overloaded magic"),
a0d0e21e
LW
1439 SvAMAGIC(right)?
1440 HvNAME(SvSTASH(SvRV(right))):
46fc3d4c 1441 ""));
a0d0e21e 1442 if (amtp && amtp->fallback >= AMGfallYES) {
cea2e8a9 1443 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
a0d0e21e 1444 } else {
894356b3 1445 Perl_croak(aTHX_ "%"SVf, msg);
a0d0e21e
LW
1446 }
1447 return NULL;
1448 }
ee239bfe 1449 force_cpy = force_cpy || assign;
a0d0e21e
LW
1450 }
1451 }
1452 if (!notfound) {
cea2e8a9 1453 DEBUG_o( Perl_deb(aTHX_
46fc3d4c 1454 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
22c35a8c 1455 PL_AMG_names[off],
748a9306
LW
1456 method+assignshift==off? "" :
1457 " (initially `",
1458 method+assignshift==off? "" :
22c35a8c 1459 PL_AMG_names[method+assignshift],
748a9306
LW
1460 method+assignshift==off? "" : "')",
1461 flags & AMGf_unary? "" :
1462 lr==1 ? " for right argument": " for left argument",
1463 flags & AMGf_unary? " for argument" : "",
a0d0e21e
LW
1464 HvNAME(stash),
1465 fl? ",\n\tassignment variant used": "") );
ee239bfe 1466 }
748a9306
LW
1467 /* Since we use shallow copy during assignment, we need
1468 * to dublicate the contents, probably calling user-supplied
1469 * version of copy operator
1470 */
ee239bfe
IZ
1471 /* We need to copy in following cases:
1472 * a) Assignment form was called.
1473 * assignshift==1, assign==T, method + 1 == off
1474 * b) Increment or decrement, called directly.
1475 * assignshift==0, assign==0, method + 0 == off
1476 * c) Increment or decrement, translated to assignment add/subtr.
1477 * assignshift==0, assign==T,
1478 * force_cpy == T
1479 * d) Increment or decrement, translated to nomethod.
1480 * assignshift==0, assign==0,
1481 * force_cpy == T
1482 * e) Assignment form translated to nomethod.
1483 * assignshift==1, assign==T, method + 1 != off
1484 * force_cpy == T
1485 */
1486 /* off is method, method+assignshift, or a result of opcode substitution.
1487 * In the latter case assignshift==0, so only notfound case is important.
1488 */
1489 if (( (method + assignshift == off)
1490 && (assign || (method == inc_amg) || (method == dec_amg)))
1491 || force_cpy)
1492 RvDEEPCP(left);
a0d0e21e
LW
1493 {
1494 dSP;
1495 BINOP myop;
1496 SV* res;
54310121 1497 bool oldcatch = CATCH_GET;
a0d0e21e 1498
54310121 1499 CATCH_SET(TRUE);
a0d0e21e
LW
1500 Zero(&myop, 1, BINOP);
1501 myop.op_last = (OP *) &myop;
1502 myop.op_next = Nullop;
54310121 1503 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
a0d0e21e 1504
e788e7d3 1505 PUSHSTACKi(PERLSI_OVERLOAD);
a0d0e21e 1506 ENTER;
462e5cf6 1507 SAVEOP();
533c011a 1508 PL_op = (OP *) &myop;
3280af22 1509 if (PERLDB_SUB && PL_curstash != PL_debstash)
533c011a 1510 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 1511 PUTBACK;
cea2e8a9 1512 pp_pushmark();
a0d0e21e 1513
924508f0 1514 EXTEND(SP, notfound + 5);
a0d0e21e
LW
1515 PUSHs(lr>0? right: left);
1516 PUSHs(lr>0? left: right);
3280af22 1517 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
a0d0e21e 1518 if (notfound) {
22c35a8c 1519 PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
a0d0e21e
LW
1520 }
1521 PUSHs((SV*)cv);
1522 PUTBACK;
1523
cea2e8a9
GS
1524 if (PL_op = Perl_pp_entersub(aTHX))
1525 CALLRUNOPS(aTHX);
a0d0e21e
LW
1526 LEAVE;
1527 SPAGAIN;
1528
1529 res=POPs;
ebafeae7 1530 PUTBACK;
d3acc0f7 1531 POPSTACK;
54310121 1532 CATCH_SET(oldcatch);
a0d0e21e 1533
a0d0e21e
LW
1534 if (postpr) {
1535 int ans;
1536 switch (method) {
1537 case le_amg:
1538 case sle_amg:
1539 ans=SvIV(res)<=0; break;
1540 case lt_amg:
1541 case slt_amg:
1542 ans=SvIV(res)<0; break;
1543 case ge_amg:
1544 case sge_amg:
1545 ans=SvIV(res)>=0; break;
1546 case gt_amg:
1547 case sgt_amg:
1548 ans=SvIV(res)>0; break;
1549 case eq_amg:
1550 case seq_amg:
1551 ans=SvIV(res)==0; break;
1552 case ne_amg:
1553 case sne_amg:
1554 ans=SvIV(res)!=0; break;
1555 case inc_amg:
1556 case dec_amg:
bbce6d69 1557 SvSetSV(left,res); return left;
dc437b57 1558 case not_amg:
fe7ac86a 1559 ans=!SvTRUE(res); break;
a0d0e21e 1560 }
54310121 1561 return boolSV(ans);
748a9306
LW
1562 } else if (method==copy_amg) {
1563 if (!SvROK(res)) {
cea2e8a9 1564 Perl_croak(aTHX_ "Copy method did not return a reference");
748a9306
LW
1565 }
1566 return SvREFCNT_inc(SvRV(res));
a0d0e21e
LW
1567 } else {
1568 return res;
1569 }
1570 }
1571}