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