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