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