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