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