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