File Coverage

gv.c
Criterion Covered Total %
statement 1081 1147 94.2
branch 1422 1978 71.9
condition n/a
subroutine n/a
total 2503 3125 80.1


line stmt bran cond sub time code
1           /* gv.c
2           *
3           * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4           * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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 in 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           * [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"]
20           */
21            
22           /*
23           =head1 GV Functions
24            
25           A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
26           It is a structure that holds a pointer to a scalar, an array, a hash etc,
27           corresponding to $foo, @foo, %foo.
28            
29           GVs are usually found as values in stashes (symbol table hashes) where
30           Perl stores its global variables.
31            
32           =cut
33           */
34            
35           #include "EXTERN.h"
36           #define PERL_IN_GV_C
37           #include "perl.h"
38           #include "overload.c"
39           #include "keywords.h"
40           #include "feature.h"
41            
42           static const char S_autoload[] = "AUTOLOAD";
43           static const STRLEN S_autolen = sizeof(S_autoload)-1;
44            
45           GV *
46 8978005         Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
47           {
48           SV **where;
49            
50 8978005 50       if (
51           !gv
52 8978005 100       || (
53 8978005         SvTYPE((const SV *)gv) != SVt_PVGV
54 8978005         && SvTYPE((const SV *)gv) != SVt_PVLV
55           )
56           ) {
57           const char *what;
58 2 50       if (type == SVt_PVIO) {
59           /*
60           * if it walks like a dirhandle, then let's assume that
61           * this is a dirhandle.
62           */
63 2         what = OP_IS_DIRHOP(PL_op->op_type) ?
64 2 50       "dirhandle" : "filehandle";
65 0 0       } else if (type == SVt_PVHV) {
66           what = "hash";
67           } else {
68 0 0       what = type == SVt_PVAV ? "array" : "scalar";
69           }
70           /* diag_listed_as: Bad symbol for filehandle */
71 2         Perl_croak(aTHX_ "Bad symbol for %s", what);
72           }
73            
74 8978003 100       if (type == SVt_PVHV) {
75 510435         where = (SV **)&GvHV(gv);
76 8467568 100       } else if (type == SVt_PVAV) {
77 1292367         where = (SV **)&GvAV(gv);
78 7175201 100       } else if (type == SVt_PVIO) {
79 5044649         where = (SV **)&GvIOp(gv);
80           } else {
81 2130552         where = &GvSV(gv);
82           }
83            
84 8978003 100       if (!*where)
85 8800493         *where = newSV_type(type);
86 8978003 100       if (type == SVt_PVAV && GvNAMELEN(gv) == 3
    100        
87 514500 100       && strnEQ(GvNAME(gv), "ISA", 3))
88 447148         sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
89 8978003         return gv;
90           }
91            
92           GV *
93 12864415         Perl_gv_fetchfile(pTHX_ const char *name)
94           {
95           PERL_ARGS_ASSERT_GV_FETCHFILE;
96 12864415         return gv_fetchfile_flags(name, strlen(name), 0);
97           }
98            
99           GV *
100 13170899         Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
101           const U32 flags)
102           {
103           dVAR;
104           char smallbuf[128];
105           char *tmpbuf;
106 13170899         const STRLEN tmplen = namelen + 2;
107           GV *gv;
108            
109           PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
110           PERL_UNUSED_ARG(flags);
111            
112 13170899 50       if (!PL_defstash)
113           return NULL;
114            
115 13170899 100       if (tmplen <= sizeof smallbuf)
116           tmpbuf = smallbuf;
117           else
118 34         Newx(tmpbuf, tmplen, char);
119           /* This is where the debugger's %{"::_<$filename"} hash is created */
120 13170899         tmpbuf[0] = '_';
121 13170899         tmpbuf[1] = '<';
122 13170899         memcpy(tmpbuf + 2, name, namelen);
123 13170899         gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
124 13170899 100       if (!isGV(gv)) {
125 4626469         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
126           #ifdef PERL_DONT_CREATE_GVSV
127 4626469         GvSV(gv) = newSVpvn(name, namelen);
128           #else
129           sv_setpvn(GvSV(gv), name, namelen);
130           #endif
131           }
132 13170899 100       if ((PERLDB_LINE || PERLDB_SAVESRC) && !GvAV(gv))
    100        
    100        
133 7340 50       hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
134 13170899 100       if (tmpbuf != smallbuf)
135 6714689         Safefree(tmpbuf);
136           return gv;
137           }
138            
139           /*
140           =for apidoc gv_const_sv
141            
142           If C is a typeglob whose subroutine entry is a constant sub eligible for
143           inlining, or C is a placeholder reference that would be promoted to such
144           a typeglob, then returns the value returned by the sub. Otherwise, returns
145           NULL.
146            
147           =cut
148           */
149            
150           SV *
151 0         Perl_gv_const_sv(pTHX_ GV *gv)
152           {
153           PERL_ARGS_ASSERT_GV_CONST_SV;
154            
155 0 0       if (SvTYPE(gv) == SVt_PVGV)
156 0 0       return cv_const_sv(GvCVu(gv));
157 0 0       return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV ? SvRV(gv) : NULL;
    0        
158           }
159            
160           GP *
161 38270290         Perl_newGP(pTHX_ GV *const gv)
162           {
163           GP *gp;
164           U32 hash;
165           const char *file;
166           STRLEN len;
167           #ifndef USE_ITHREADS
168           GV *filegv;
169           #endif
170           dVAR;
171            
172           PERL_ARGS_ASSERT_NEWGP;
173 38270290         Newxz(gp, 1, GP);
174 38270290         gp->gp_egv = gv; /* allow compiler to reuse gv after this */
175           #ifndef PERL_DONT_CREATE_GVSV
176           gp->gp_sv = newSV(0);
177           #endif
178            
179           /* PL_curcop should never be null here. */
180           assert(PL_curcop);
181           /* But for non-debugging builds play it safe */
182 38270290 50       if (PL_curcop) {
183 38270290         gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
184           #ifdef USE_ITHREADS
185           if (CopFILE(PL_curcop)) {
186           file = CopFILE(PL_curcop);
187           len = strlen(file);
188           }
189           #else
190 38270290         filegv = CopFILEGV(PL_curcop);
191 38270290 100       if (filegv) {
192 37976542         file = GvNAME(filegv)+2;
193 37976542         len = GvNAMELEN(filegv)-2;
194           }
195           #endif
196           else goto no_file;
197           }
198           else {
199           no_file:
200           file = "";
201           len = 0;
202           }
203            
204 38270290         PERL_HASH(hash, file, len);
205 38270290         gp->gp_file_hek = share_hek(file, len, hash);
206 38270290         gp->gp_refcnt = 1;
207            
208 38270290         return gp;
209           }
210            
211           /* Assign CvGV(cv) = gv, handling weak references.
212           * See also S_anonymise_cv_maybe */
213            
214           void
215 34737669         Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
216           {
217           GV * const oldgv = CvGV(cv);
218           HEK *hek;
219           PERL_ARGS_ASSERT_CVGV_SET;
220            
221 34737669 100       if (oldgv == gv)
222           return;
223            
224 31063026 100       if (oldgv) {
225 5336596 100       if (CvCVGV_RC(cv)) {
226 3049985         SvREFCNT_dec_NN(oldgv);
227 3049985         CvCVGV_RC_off(cv);
228           }
229           else {
230 2286611         sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
231           }
232           }
233 25726430 50       else if ((hek = CvNAME_HEK(cv))) unshare_hek(hek);
234            
235 31063024         SvANY(cv)->xcv_gv_u.xcv_gv = gv;
236           assert(!CvCVGV_RC(cv));
237            
238 31063024 100       if (!gv)
239           return;
240            
241 25726432 50       if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
    50        
    50        
    100        
    100        
242 21932892         Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
243           else {
244 3793540         CvCVGV_RC_on(cv);
245 19659741         SvREFCNT_inc_simple_void_NN(gv);
246           }
247           }
248            
249           /* Assign CvSTASH(cv) = st, handling weak references. */
250            
251           void
252 22122421         Perl_cvstash_set(pTHX_ CV *cv, HV *st)
253           {
254 22122421         HV *oldst = CvSTASH(cv);
255           PERL_ARGS_ASSERT_CVSTASH_SET;
256 22122421 100       if (oldst == st)
257 22122421         return;
258 22016853 100       if (oldst)
259 2028         sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
260 22016853         SvANY(cv)->xcv_stash = st;
261 22016853 50       if (st)
262 22016853         Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
263           }
264            
265           /*
266           =for apidoc gv_init_pvn
267            
268           Converts a scalar into a typeglob. This is an incoercible typeglob;
269           assigning a reference to it will assign to one of its slots, instead of
270           overwriting it as happens with typeglobs created by SvSetSV. Converting
271           any scalar that is SvOK() may produce unpredictable results and is reserved
272           for perl's internal use.
273            
274           C is the scalar to be converted.
275            
276           C is the parent stash/package, if any.
277            
278           C and C give the name. The name must be unqualified;
279           that is, it must not include the package name. If C is a
280           stash element, it is the caller's responsibility to ensure that the name
281           passed to this function matches the name of the element. If it does not
282           match, perl's internal bookkeeping will get out of sync.
283            
284           C can be set to SVf_UTF8 if C is a UTF8 string, or
285           the return value of SvUTF8(sv). It can also take the
286           GV_ADDMULTI flag, which means to pretend that the GV has been
287           seen before (i.e., suppress "Used once" warnings).
288            
289           =for apidoc gv_init
290            
291           The old form of gv_init_pvn(). It does not work with UTF8 strings, as it
292           has no flags parameter. If the C parameter is set, the
293           GV_ADDMULTI flag will be passed to gv_init_pvn().
294            
295           =for apidoc gv_init_pv
296            
297           Same as gv_init_pvn(), but takes a nul-terminated string for the name
298           instead of separate char * and length parameters.
299            
300           =for apidoc gv_init_sv
301            
302           Same as gv_init_pvn(), but takes an SV * for the name instead of separate
303           char * and length parameters. C is currently unused.
304            
305           =cut
306           */
307            
308           void
309 2473042         Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
310           {
311           char *namepv;
312           STRLEN namelen;
313           PERL_ARGS_ASSERT_GV_INIT_SV;
314 2473042 50       namepv = SvPV(namesv, namelen);
315 2473042 100       if (SvUTF8(namesv))
316 16         flags |= SVf_UTF8;
317 2473042         gv_init_pvn(gv, stash, namepv, namelen, flags);
318 2473042         }
319            
320           void
321 2         Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
322           {
323           PERL_ARGS_ASSERT_GV_INIT_PV;
324 2         gv_init_pvn(gv, stash, name, strlen(name), flags);
325 2         }
326            
327           void
328 35898302         Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
329           {
330           dVAR;
331 35898302         const U32 old_type = SvTYPE(gv);
332 35898302         const bool doproto = old_type > SVt_NULL;
333 5301788 100       char * const proto = (doproto && SvPOK(gv))
334 242441         ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
335 36363480 100       : NULL;
    100        
336 35898302 100       const STRLEN protolen = proto ? SvCUR(gv) : 0;
337 35898302 100       const U32 proto_utf8 = proto ? SvUTF8(gv) : 0;
338 35898302 100       SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
    100        
339 35898302 100       const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
    100        
340            
341           PERL_ARGS_ASSERT_GV_INIT_PVN;
342           assert (!(proto && has_constant));
343            
344 35898302 100       if (has_constant) {
345           /* The constant has to be a simple scalar type. */
346 4785864 100       switch (SvTYPE(has_constant)) {
347           case SVt_PVHV:
348           case SVt_PVCV:
349           case SVt_PVFM:
350           case SVt_PVIO:
351 20         Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
352           sv_reftype(has_constant, 0));
353           default: NOOP;
354           }
355 4785844         SvRV_set(gv, NULL);
356 4785844         SvROK_off(gv);
357           }
358            
359            
360 35898282 50       if (old_type < SVt_PVGV) {
361 35898282 100       if (old_type >= SVt_PV)
362 276032         SvCUR_set(gv, 0);
363 35898282         sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
364           }
365 35898282 100       if (SvLEN(gv)) {
366 276030 50       if (proto) {
367 276030         SvPV_set(gv, NULL);
368 276030         SvLEN_set(gv, 0);
369 276030         SvPOK_off(gv);
370           } else
371 0         Safefree(SvPVX_mutable(gv));
372           }
373 35898282         SvIOK_off(gv);
374 35898282         isGV_with_GP_on(gv);
375            
376 35898282         GvGP_set(gv, Perl_newGP(aTHX_ gv));
377 35898282         GvSTASH(gv) = stash;
378 35898282 100       if (stash)
379 35690904         Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
380 35898282         gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
381 35898282 100       if (flags & GV_ADDMULTI || doproto) /* doproto means it */
    100        
382 24951871         GvMULTI_on(gv); /* _was_ mentioned */
383 35898282 100       if (doproto) {
384           CV *cv;
385 5301768 100       if (has_constant) {
386           /* newCONSTSUB takes ownership of the reference from us. */
387 4785844         cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
388           /* In case op.c:S_process_special_blocks stole it: */
389 4785844 100       if (!GvCV(gv))
390 4         GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
391           assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
392           /* If this reference was a copy of another, then the subroutine
393           must have been "imported", by a Perl space assignment to a GV
394           from a reference to CV. */
395 4785844 100       if (exported_constant)
396 1100232         GvIMPORTED_CV_on(gv);
397 4785844         CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
398           } else {
399 515924         cv = newSTUB(gv,1);
400           }
401 5301768 100       if (proto) {
402 276030         sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
403           SV_HAS_TRAILING_NUL);
404 276030 100       if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
405           }
406           }
407 35898282         }
408            
409           STATIC void
410 116782932         S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
411           {
412           PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
413            
414 116782932         switch (sv_type) {
415           case SVt_PVIO:
416 507167 50       (void)GvIOn(gv);
    50        
    50        
    100        
417           break;
418           case SVt_PVAV:
419 11597269 100       (void)GvAVn(gv);
420           break;
421           case SVt_PVHV:
422 3504716 100       (void)GvHVn(gv);
423           break;
424           #ifdef PERL_DONT_CREATE_GVSV
425           case SVt_NULL:
426           case SVt_PVCV:
427           case SVt_PVFM:
428           case SVt_PVGV:
429           break;
430           default:
431 18854149 100       if(GvSVn(gv)) {
432           /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
433           If we just cast GvSVn(gv) to void, it ignores evaluating it for
434           its side effect */
435           }
436           #endif
437           }
438 116782932         }
439            
440           static void core_xsub(pTHX_ CV* cv);
441            
442           static GV *
443 13498         S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
444           const char * const name, const STRLEN len)
445           {
446 13498         const int code = keyword(name, len, 1);
447           static const char file[] = __FILE__;
448           CV *cv, *oldcompcv = NULL;
449 13498         int opnum = 0;
450           bool ampable = TRUE; /* &{}-able */
451           COP *oldcurcop = NULL;
452           yy_parser *oldparser = NULL;
453           I32 oldsavestack_ix = 0;
454            
455           assert(gv || stash);
456           assert(name);
457            
458 13498 100       if (!code) return NULL; /* Not a keyword */
459 12858         switch (code < 0 ? -code : code) {
460           /* no support for \&CORE::infix;
461           no support for funcs that do not parse like funcs */
462           case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
463           case KEY_BEGIN : case KEY_CHECK : case KEY_cmp: case KEY_CORE :
464           case KEY_default : case KEY_DESTROY:
465           case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif :
466           case KEY_END : case KEY_eq : case KEY_eval :
467           case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge :
468           case KEY_given : case KEY_goto : case KEY_grep :
469           case KEY_gt : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le:
470           case KEY_local: case KEY_lt: case KEY_m : case KEY_map : case KEY_my:
471           case KEY_ne : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
472           case KEY_package: case KEY_print: case KEY_printf:
473           case KEY_q : case KEY_qq : case KEY_qr : case KEY_qw :
474           case KEY_qx : case KEY_redo : case KEY_require: case KEY_return:
475           case KEY_s : case KEY_say : case KEY_sort :
476           case KEY_state: case KEY_sub :
477           case KEY_tr : case KEY_UNITCHECK: case KEY_unless:
478           case KEY_until: case KEY_use : case KEY_when : case KEY_while :
479           case KEY_x : case KEY_xor : case KEY_y :
480           return NULL;
481           case KEY_chdir:
482           case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
483           case KEY_each : case KEY_eof : case KEY_exec : case KEY_exists:
484           case KEY_keys:
485           case KEY_lstat:
486           case KEY_pop:
487           case KEY_push:
488           case KEY_shift:
489           case KEY_splice: case KEY_split:
490           case KEY_stat:
491           case KEY_system:
492           case KEY_truncate: case KEY_unlink:
493           case KEY_unshift:
494           case KEY_values:
495           ampable = FALSE;
496           }
497 816 100       if (!gv) {
498 2         gv = (GV *)newSV(0);
499 2         gv_init(gv, stash, name, len, TRUE);
500           }
501 816         GvMULTI_on(gv);
502 816 100       if (ampable) {
503 728         ENTER;
504 728         oldcurcop = PL_curcop;
505 728         oldparser = PL_parser;
506 728         lex_start(NULL, NULL, 0);
507 728         oldcompcv = PL_compcv;
508 728         PL_compcv = NULL; /* Prevent start_subparse from setting
509           CvOUTSIDE. */
510 728         oldsavestack_ix = start_subparse(FALSE,0);
511 728         cv = PL_compcv;
512           }
513           else {
514           /* Avoid calling newXS, as it calls us, and things start to
515           get hairy. */
516 88         cv = MUTABLE_CV(newSV_type(SVt_PVCV));
517 88         GvCV_set(gv,cv);
518 88         GvCVGEN(gv) = 0;
519 88         mro_method_changed_in(GvSTASH(gv));
520 88         CvISXSUB_on(cv);
521 88         CvXSUB(cv) = core_xsub;
522           }
523 816         CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
524           from PL_curcop. */
525 816         (void)gv_fetchfile(file);
526 816         CvFILE(cv) = (char *)file;
527           /* XXX This is inefficient, as doing things this order causes
528           a prototype check in newATTRSUB. But we have to do
529           it this order as we need an op number before calling
530           new ATTRSUB. */
531 816         (void)core_prototype((SV *)cv, name, code, &opnum);
532 816 100       if (stash)
533 2         (void)hv_store(stash,name,len,(SV *)gv,0);
534 816 100       if (ampable) {
535           #ifdef DEBUGGING
536           CV *orig_cv = cv;
537           #endif
538 728         CvLVALUE_on(cv);
539           /* newATTRSUB will free the CV and return NULL if we're still
540           compiling after a syntax error */
541 728 100       if ((cv = newATTRSUB_flags(
    100        
542           oldsavestack_ix, (OP *)gv,
543           NULL,NULL,
544           coresub_op(
545           opnum
546           ? newSVuv((UV)opnum)
547           : newSVpvn(name,len),
548           code, opnum
549           ),
550           1
551           )) != NULL) {
552           assert(GvCV(gv) == orig_cv);
553 726 100       if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
554 714 100       && opnum != OP_UNDEF)
555 710         CvLVALUE_off(cv); /* Now *that* was a neat trick. */
556           }
557 728         LEAVE;
558 728         PL_parser = oldparser;
559 728         PL_curcop = oldcurcop;
560 728         PL_compcv = oldcompcv;
561           }
562 816 100       if (cv) {
563 814 100       SV *opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
564 814 100       cv_set_call_checker(
565           cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
566           );
567 7156         SvREFCNT_dec(opnumsv);
568           }
569            
570           return gv;
571           }
572            
573           /*
574           =for apidoc gv_fetchmeth
575            
576           Like L, but lacks a flags parameter.
577            
578           =for apidoc gv_fetchmeth_sv
579            
580           Exactly like L, but takes the name string in the form
581           of an SV instead of a string/length pair.
582            
583           =cut
584           */
585            
586           GV *
587 18         Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
588           {
589           char *namepv;
590           STRLEN namelen;
591           PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
592 18 50       namepv = SvPV(namesv, namelen);
593 18 100       if (SvUTF8(namesv))
594 4         flags |= SVf_UTF8;
595 18         return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
596           }
597            
598           /*
599           =for apidoc gv_fetchmeth_pv
600            
601           Exactly like L, but takes a nul-terminated string
602           instead of a string/length pair.
603            
604           =cut
605           */
606            
607           GV *
608 18         Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
609           {
610           PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
611 18         return gv_fetchmeth_pvn(stash, name, strlen(name), level, flags);
612           }
613            
614           /*
615           =for apidoc gv_fetchmeth_pvn
616            
617           Returns the glob with the given C and a defined subroutine or
618           C. The glob lives in the given C, or in the stashes
619           accessible via @ISA and UNIVERSAL::.
620            
621           The argument C should be either 0 or -1. If C, as a
622           side-effect creates a glob with the given C in the given C
623           which in the case of success contains an alias for the subroutine, and sets
624           up caching info for this glob.
625            
626           The only significant values for C are GV_SUPER and SVf_UTF8.
627            
628           GV_SUPER indicates that we want to look up the method in the superclasses
629           of the C.
630            
631           The
632           GV returned from C may be a method cache entry, which is not
633           visible to Perl code. So when calling C, you should not use
634           the GV directly; instead, you should use the method's CV, which can be
635           obtained from the GV with the C macro.
636            
637           =cut
638           */
639            
640           /* NOTE: No support for tied ISA */
641            
642           GV *
643 144632103         Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
644           {
645           dVAR;
646           GV** gvp;
647           AV* linear_av;
648           SV** linear_svp;
649           SV* linear_sv;
650           HV* cstash, *cachestash;
651           GV* candidate = NULL;
652           CV* cand_cv = NULL;
653           GV* topgv = NULL;
654           const char *hvname;
655 144632103         I32 create = (level >= 0) ? 1 : 0;
656           I32 items;
657           U32 topgen_cmp;
658 144632103         U32 is_utf8 = flags & SVf_UTF8;
659            
660           PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
661            
662           /* UNIVERSAL methods should be callable without a stash */
663 144632103 100       if (!stash) {
664           create = 0; /* probably appropriate */
665 11608825 100       if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
666           return 0;
667           }
668            
669           assert(stash);
670            
671 144632027 50       hvname = HvNAME_get(stash);
    50        
    100        
    100        
    50        
    100        
672 144632027 100       if (!hvname)
673 4         Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
674            
675           assert(hvname);
676           assert(name);
677            
678           DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
679           flags & GV_SUPER ? "SUPER " : "",name,hvname) );
680            
681 144632023 100       topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
682            
683 144632023 100       if (flags & GV_SUPER) {
684 156508 100       if (!HvAUX(stash)->xhv_mro_meta->super)
685 3824         HvAUX(stash)->xhv_mro_meta->super = newHV();
686 156508         cachestash = HvAUX(stash)->xhv_mro_meta->super;
687           }
688           else cachestash = stash;
689            
690           /* check locally for a real method or a cache entry */
691 144632023 100       gvp = (GV**)hv_fetch(cachestash, name, is_utf8 ? -(I32)len : (I32)len,
    100        
692           create);
693 144632023 100       if(gvp) {
694 132992778         topgv = *gvp;
695           have_gv:
696           assert(topgv);
697 132992782 100       if (SvTYPE(topgv) != SVt_PVGV)
698 1422788         gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
699 132992782 100       if ((cand_cv = GvCV(topgv))) {
700           /* If genuine method or valid cache entry, use it */
701 110130686 100       if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
    100        
702           return topgv;
703           }
704           else {
705           /* stale cache entry, junk it and move on */
706 5141430         SvREFCNT_dec_NN(cand_cv);
707 5141430         GvCV_set(topgv, NULL);
708           cand_cv = NULL;
709 5141430         GvCVGEN(topgv) = 0;
710           }
711           }
712 22862096 100       else if (GvCVGEN(topgv) == topgen_cmp) {
713           /* cache indicates no such method definitively */
714           return 0;
715           }
716 12583564 100       else if (stash == cachestash
717 12578550 50       && len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
    50        
    100        
    50        
    100        
    100        
718 17376 100       && strnEQ(hvname, "CORE", 4)
719 4 50       && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
720           goto have_gv;
721           }
722            
723 25178308         linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
724 25178308         linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
725 25178308         items = AvFILLp(linear_av); /* no +1, to skip over self */
726 88596870 100       while (items--) {
727 54895606         linear_sv = *linear_svp++;
728           assert(linear_sv);
729 54895606         cstash = gv_stashsv(linear_sv, 0);
730            
731 54895606 100       if (!cstash) {
732 110 50       Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
    50        
733           "Can't locate package %"SVf" for @%"HEKf"::ISA",
734           SVfARG(linear_sv),
735 88 50       HEKfARG(HvNAME_HEK(stash)));
736 44         continue;
737           }
738            
739           assert(cstash);
740            
741 54895562 100       gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0);
742 54895562 100       if (!gvp) {
743 28742114 100       if (len > 1 && HvNAMELEN_get(cstash) == 4) {
    50        
    50        
    100        
    50        
    100        
    100        
744 12644 50       const char *hvname = HvNAME(cstash); assert(hvname);
    50        
    100        
    50        
    50        
    100        
745 12644 100       if (strnEQ(hvname, "CORE", 4)
746 12568 100       && (candidate =
747           S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
748           ))
749           goto have_candidate;
750           }
751 28742112         continue;
752           }
753 26153448         else candidate = *gvp;
754           have_candidate:
755           assert(candidate);
756 26153450 50       if (SvTYPE(candidate) != SVt_PVGV)
757 0         gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
758 26153450 50       if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
    100        
    100        
759           /*
760           * Found real method, cache method in topgv if:
761           * 1. topgv has no synonyms (else inheritance crosses wires)
762           * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
763           */
764 4024336 100       if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
    100        
    100        
    50        
765 4005608         CV *old_cv = GvCV(topgv);
766 4005608         SvREFCNT_dec(old_cv);
767 4005608         SvREFCNT_inc_simple_void_NN(cand_cv);
768 4005608         GvCV_set(topgv, cand_cv);
769 29447183         GvCVGEN(topgv) = topgen_cmp;
770           }
771           return candidate;
772           }
773           }
774            
775           /* Check UNIVERSAL without caching */
776 21153972 100       if(level == 0 || level == -1) {
777 11607979         candidate = gv_fetchmeth_pvn(NULL, name, len, 1, flags &~GV_SUPER);
778 11607979 100       if(candidate) {
779 2039988         cand_cv = GvCV(candidate);
780 2039988 50       if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
    100        
    50        
    0        
781 2039986         CV *old_cv = GvCV(topgv);
782 2039986         SvREFCNT_dec(old_cv);
783 2039986         SvREFCNT_inc_simple_void_NN(cand_cv);
784 2039986         GvCV_set(topgv, cand_cv);
785 2039986         GvCVGEN(topgv) = topgen_cmp;
786           }
787           return candidate;
788           }
789           }
790            
791 19113984 100       if (topgv && GvREFCNT(topgv) == 1) {
    100        
792           /* cache the fact that the method is not defined */
793 76102503         GvCVGEN(topgv) = topgen_cmp;
794           }
795            
796           return 0;
797           }
798            
799           /*
800           =for apidoc gv_fetchmeth_autoload
801            
802           This is the old form of L, which has no flags
803           parameter.
804            
805           =for apidoc gv_fetchmeth_sv_autoload
806            
807           Exactly like L, but takes the name string in the form
808           of an SV instead of a string/length pair.
809            
810           =cut
811           */
812            
813           GV *
814 28         Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
815           {
816           char *namepv;
817           STRLEN namelen;
818           PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
819 28 50       namepv = SvPV(namesv, namelen);
820 28 100       if (SvUTF8(namesv))
821 6         flags |= SVf_UTF8;
822 28         return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
823           }
824            
825           /*
826           =for apidoc gv_fetchmeth_pv_autoload
827            
828           Exactly like L, but takes a nul-terminated string
829           instead of a string/length pair.
830            
831           =cut
832           */
833            
834           GV *
835 24         Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
836           {
837           PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
838 24         return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
839           }
840            
841           /*
842           =for apidoc gv_fetchmeth_pvn_autoload
843            
844           Same as gv_fetchmeth_pvn(), but looks for autoloaded subroutines too.
845           Returns a glob for the subroutine.
846            
847           For an autoloaded subroutine without a GV, will create a GV even
848           if C. For an autoloaded subroutine without a stub, GvCV()
849           of the result may be zero.
850            
851           Currently, the only significant value for C is SVf_UTF8.
852            
853           =cut
854           */
855            
856           GV *
857 4176327         Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
858           {
859 4176327         GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
860            
861           PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
862            
863 4176327 100       if (!gv) {
864           CV *cv;
865           GV **gvp;
866            
867 3974422 50       if (!stash)
868           return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
869 3974422 50       if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
    0        
870           return NULL;
871 3974422 100       if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
872           return NULL;
873 332         cv = GvCV(gv);
874 332 100       if (!(CvROOT(cv) || CvXSUB(cv)))
    50        
875           return NULL;
876           /* Have an autoload */
877 330 100       if (level < 0) /* Cannot do without a stub */
878 16         gv_fetchmeth_pvn(stash, name, len, 0, flags);
879 330 100       gvp = (GV**)hv_fetch(stash, name,
    100        
880           (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
881 330 50       if (!gvp)
882           return NULL;
883 2090487         return *gvp;
884           }
885           return gv;
886           }
887            
888           /*
889           =for apidoc gv_fetchmethod_autoload
890            
891           Returns the glob which contains the subroutine to call to invoke the method
892           on the C. In fact in the presence of autoloading this may be the
893           glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
894           already setup.
895            
896           The third parameter of C determines whether
897           AUTOLOAD lookup is performed if the given method is not present: non-zero
898           means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
899           Calling C is equivalent to calling C
900           with a non-zero C parameter.
901            
902           These functions grant C<"SUPER"> token as a prefix of the method name. Note
903           that if you want to keep the returned glob for a long time, you need to
904           check for it being "AUTOLOAD", since at the later time the call may load a
905           different subroutine due to $AUTOLOAD changing its value. Use the glob
906           created via a side effect to do this.
907            
908           These functions have the same side-effects and as C with
909           C. C should be writable if contains C<':'> or C<'
910           ''>. The warning against passing the GV returned by C to
911           C apply equally to these functions.
912            
913           =cut
914           */
915            
916           GV *
917 87680         Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
918           {
919           PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
920            
921 87680 100       return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
922           }
923            
924           GV *
925 122100687         Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
926           {
927           char *namepv;
928           STRLEN namelen;
929           PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
930 122100687 100       namepv = SvPV(namesv, namelen);
931 122100687 100       if (SvUTF8(namesv))
932 762         flags |= SVf_UTF8;
933 122100687         return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
934           }
935            
936           GV *
937 87696         Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
938           {
939           PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
940 87696         return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
941           }
942            
943           /* Don't merge this yet, as it's likely to get a len parameter, and possibly
944           even a U32 hash */
945           GV *
946 122188397         Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
947           {
948           dVAR;
949           const char *nend;
950           const char *nsplit = NULL;
951           GV* gv;
952           HV* ostash = stash;
953           const char * const origname = name;
954           SV *const error_report = MUTABLE_SV(stash);
955 122188397         const U32 autoload = flags & GV_AUTOLOAD;
956 122188397         const U32 do_croak = flags & GV_CROAK;
957 122188397         const U32 is_utf8 = flags & SVf_UTF8;
958            
959           PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
960            
961 122188397 100       if (SvTYPE(stash) < SVt_PVHV)
962           stash = NULL;
963           else {
964           /* The only way stash can become NULL later on is if nsplit is set,
965           which in turn means that there is no need for a SVt_PVHV case
966           the error reporting code. */
967           }
968            
969 874589114 100       for (nend = name; *nend || nend != (origname + len); nend++) {
    100        
970 752400717 50       if (*nend == '\'') {
971           nsplit = nend;
972 0         name = nend + 1;
973           }
974 752400717 100       else if (*nend == ':' && *(nend + 1) == ':') {
    50        
975 167128         nsplit = nend++;
976 167128         name = nend + 1;
977           }
978           }
979 122188397 100       if (nsplit) {
980 166786 100       if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
    100        
981           /* ->SUPER::method should really be looked up in original stash */
982 156504         stash = CopSTASH(PL_curcop);
983 156504         flags |= GV_SUPER;
984           DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
985           origname, HvENAME_get(stash), name) );
986           }
987 14724 100       else if ((nsplit - origname) >= 7 &&
    100        
988 9964         strnEQ(nsplit - 7, "::SUPER", 7)) {
989           /* don't autovifify if ->NoSuchStash::SUPER::method */
990 4         stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8);
991 4 50       if (stash) flags |= GV_SUPER;
992           }
993           else {
994           /* don't autovifify if ->NoSuchStash::method */
995 88712         stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
996           }
997           ostash = stash;
998           }
999            
1000 122188397         gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1001 122188393 100       if (!gv) {
1002 13983500 100       if (strEQ(name,"import") || strEQ(name,"unimport"))
    50        
1003           gv = MUTABLE_GV(&PL_sv_yes);
1004 11483578 100       else if (autoload)
1005 28118         gv = gv_autoload_pvn(
1006           ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags
1007           );
1008 13983500 100       if (!gv && do_croak) {
1009           /* Right now this is exclusively for the benefit of S_method_common
1010           in pp_hot.c */
1011 358 100       if (stash) {
1012           /* If we can't find an IO::File method, it might be a call on
1013           * a filehandle. If IO:File has not been loaded, try to
1014           * require it first instead of croaking */
1015 332 50       const char *stash_name = HvNAME_get(stash);
    50        
    50        
    0        
    50        
    50        
1016 332 50       if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
    50        
    50        
    50        
    50        
    50        
    100        
    100        
1017 12 50       && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
    50        
1018           STR_WITH_LEN("IO/File.pm"), 0,
1019           HV_FETCH_ISEXISTS, NULL, 0)
1020           ) {
1021 12         require_pv("IO/File.pm");
1022 12         gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1023 12 50       if (gv)
1024           return gv;
1025           }
1026 960 50       Perl_croak(aTHX_
    50        
1027           "Can't locate object method \"%"UTF8f
1028           "\" via package \"%"HEKf"\"",
1029 320         UTF8fARG(is_utf8, nend - name, name),
1030 640 50       HEKfARG(HvNAME_HEK(stash)));
1031           }
1032           else {
1033           SV* packnamesv;
1034            
1035 26 100       if (nsplit) {
1036 8         packnamesv = newSVpvn_flags(origname, nsplit - origname,
1037           SVs_TEMP | is_utf8);
1038           } else {
1039           packnamesv = error_report;
1040           }
1041            
1042 26         Perl_croak(aTHX_
1043           "Can't locate object method \"%"UTF8f
1044           "\" via package \"%"SVf"\""
1045           " (perhaps you forgot to load \"%"SVf"\"?)",
1046 26         UTF8fARG(is_utf8, nend - name, name),
1047           SVfARG(packnamesv), SVfARG(packnamesv));
1048           }
1049           }
1050           }
1051 108204893 100       else if (autoload) {
1052 44110101         CV* const cv = GvCV(gv);
1053 44110101 100       if (!CvROOT(cv) && !CvXSUB(cv)) {
    50        
1054           GV* stubgv;
1055           GV* autogv;
1056            
1057 674 50       if (CvANON(cv))
1058           stubgv = gv;
1059           else {
1060           stubgv = CvGV(cv);
1061 674 50       if (GvCV(stubgv) != cv) /* orphaned import */
1062           stubgv = gv;
1063           }
1064 674 50       autogv = gv_autoload_pvn(GvSTASH(stubgv),
1065           GvNAME(stubgv), GvNAMELEN(stubgv),
1066           GV_AUTOLOAD_ISMETHOD
1067           | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1068 674 100       if (autogv)
1069           gv = autogv;
1070           }
1071           }
1072            
1073 122188041         return gv;
1074           }
1075            
1076           GV*
1077 10         Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1078           {
1079           char *namepv;
1080           STRLEN namelen;
1081           PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1082 10 50       namepv = SvPV(namesv, namelen);
1083 10 100       if (SvUTF8(namesv))
1084 2         flags |= SVf_UTF8;
1085 10         return gv_autoload_pvn(stash, namepv, namelen, flags);
1086           }
1087            
1088           GV*
1089 8         Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1090           {
1091           PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1092 8         return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1093           }
1094            
1095           GV*
1096 39028         Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1097           {
1098           dVAR;
1099           GV* gv;
1100           CV* cv;
1101           HV* varstash;
1102           GV* vargv;
1103           SV* varsv;
1104           SV *packname = NULL;
1105 39028         U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1106            
1107           PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1108            
1109 39028 100       if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
    50        
1110           return NULL;
1111 39028 100       if (stash) {
1112 39020 100       if (SvTYPE(stash) < SVt_PVHV) {
1113 22         STRLEN packname_len = 0;
1114 22 50       const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1115 22         packname = newSVpvn_flags(packname_ptr, packname_len,
1116           SVs_TEMP | SvUTF8(stash));
1117           stash = NULL;
1118           }
1119           else
1120 38998 50       packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
    50        
    50        
1121 39020 100       if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
1122           }
1123 39028 100       if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, is_utf8)))
1124           return NULL;
1125 38110         cv = GvCV(gv);
1126            
1127 38110 100       if (!(CvROOT(cv) || CvXSUB(cv)))
    50        
1128           return NULL;
1129            
1130           /*
1131           * Inheriting AUTOLOAD for non-methods works ... for now.
1132           */
1133 38108 100       if (
1134 38108         !(flags & GV_AUTOLOAD_ISMETHOD)
1135 10170 50       && (GvCVGEN(gv) || GvSTASH(gv) != stash)
    100        
1136           )
1137 4         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1138           "Use of inherited AUTOLOAD for non-method %"SVf
1139           "::%"UTF8f"() is deprecated",
1140           SVfARG(packname),
1141           UTF8fARG(is_utf8, len, name));
1142            
1143 38108 100       if (CvISXSUB(cv)) {
1144           /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
1145           * and split that value on the last '::', pass along the same data
1146           * via the SvPVX field in the CV, and the stash in CvSTASH.
1147           *
1148           * Due to an unfortunate accident of history, the SvPVX field
1149           * serves two purposes. It is also used for the subroutine's pro-
1150           * type. Since SvPVX has been documented as returning the sub name
1151           * for a long time, but not as returning the prototype, we have
1152           * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
1153           * elsewhere.
1154           *
1155           * We put the prototype in the same allocated buffer, but after
1156           * the sub name. The SvPOK flag indicates the presence of a proto-
1157           * type. The CvAUTOLOAD flag indicates the presence of a sub name.
1158           * If both flags are on, then SvLEN is used to indicate the end of
1159           * the prototype (artificially lower than what is actually allo-
1160           * cated), at the risk of having to reallocate a few bytes unneces-
1161           * sarily--but that should happen very rarely, if ever.
1162           *
1163           * We use SvUTF8 for both prototypes and sub names, so if one is
1164           * UTF8, the other must be upgraded.
1165           */
1166 2354         CvSTASH_set(cv, stash);
1167 2354 100       if (SvPOK(cv)) { /* Ouch! */
1168 14         SV * const tmpsv = newSVpvn_flags(name, len, is_utf8);
1169           STRLEN ulen;
1170 14 50       const char *proto = CvPROTO(cv);
    50        
    100        
1171           assert(proto);
1172 14 100       if (SvUTF8(cv))
1173 2 50       sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
    50        
    50        
1174 14         ulen = SvCUR(tmpsv);
1175 14         SvCUR(tmpsv)++; /* include null in string */
1176 14 100       sv_catpvn_flags(
    50        
    50        
    100        
1177           tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
1178           );
1179 14         SvTEMP_on(tmpsv); /* Allow theft */
1180 14         sv_setsv_nomg((SV *)cv, tmpsv);
1181 14         SvTEMP_off(tmpsv);
1182 14         SvREFCNT_dec_NN(tmpsv);
1183 14         SvLEN(cv) = SvCUR(cv) + 1;
1184 14         SvCUR(cv) = ulen;
1185           }
1186           else {
1187 2340         sv_setpvn((SV *)cv, name, len);
1188 2340         SvPOK_off(cv);
1189 2340 100       if (is_utf8)
1190 2         SvUTF8_on(cv);
1191 2338         else SvUTF8_off(cv);
1192           }
1193 2354         CvAUTOLOAD_on(cv);
1194           }
1195            
1196           /*
1197           * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1198           * The subroutine's original name may not be "AUTOLOAD", so we don't
1199           * use that, but for lack of anything better we will use the sub's
1200           * original package to look up $AUTOLOAD.
1201           */
1202 38108         varstash = GvSTASH(CvGV(cv));
1203 38108         vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1204 38108         ENTER;
1205            
1206 38108 50       if (!isGV(vargv)) {
1207 0         gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1208           #ifdef PERL_DONT_CREATE_GVSV
1209 0         GvSV(vargv) = newSV(0);
1210           #endif
1211           }
1212 38108         LEAVE;
1213 38108 100       varsv = GvSVn(vargv);
1214 38108 50       SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
1215           /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
1216 38108         sv_setsv(varsv, packname);
1217 38108         sv_catpvs(varsv, "::");
1218           /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1219           tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
1220 38108 100       sv_catpvn_flags(
1221           varsv, name, len,
1222           SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
1223           );
1224 38108 100       if (is_utf8)
1225 19881         SvUTF8_on(varsv);
1226           return gv;
1227           }
1228            
1229            
1230           /* require_tie_mod() internal routine for requiring a module
1231           * that implements the logic of automatic ties like %! and %-
1232           *
1233           * The "gv" parameter should be the glob.
1234           * "varpv" holds the name of the var, used for error messages.
1235           * "namesv" holds the module name. Its refcount will be decremented.
1236           * "methpv" holds the method name to test for to check that things
1237           * are working reasonably close to as expected.
1238           * "flags": if flag & 1 then save the scalar before loading.
1239           * For the protection of $! to work (it is set by this routine)
1240           * the sv slot must already be magicalized.
1241           */
1242           STATIC HV*
1243 23954         S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
1244           {
1245           dVAR;
1246 23954         HV* stash = gv_stashsv(namesv, 0);
1247            
1248           PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1249            
1250 29366 100       if (!stash || !(gv_fetchmethod_autoload(stash, methpv, FALSE))) {
    100        
1251 5518         SV *module = newSVsv(namesv);
1252 5518         char varname = *varpv; /* varpv might be clobbered by load_module,
1253           so save it. For the moment it's always
1254           a single char. */
1255 5518 100       const char type = varname == '[' ? '$' : '%';
1256 5518         dSP;
1257 5518         ENTER;
1258 5518         SAVEFREESV(namesv);
1259 5518 100       if ( flags & 1 )
1260 4376         save_scalar(gv);
1261 5518 100       PUSHSTACKi(PERLSI_MAGIC);
1262 5518         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1263 5416 50       POPSTACK;
1264 5416         stash = gv_stashsv(namesv, 0);
1265 5416 100       if (!stash)
1266 4         Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available",
1267           type, varname, SVfARG(namesv));
1268 5412 50       else if (!gv_fetchmethod(stash, methpv))
1269 0         Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s",
1270           type, varname, SVfARG(namesv), methpv);
1271 5412         LEAVE;
1272           }
1273 18436         else SvREFCNT_dec_NN(namesv);
1274 23848         return stash;
1275           }
1276            
1277           /*
1278           =for apidoc gv_stashpv
1279            
1280           Returns a pointer to the stash for a specified package. Uses C to
1281           determine the length of C, then calls C.
1282            
1283           =cut
1284           */
1285            
1286           HV*
1287 469819637         Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1288           {
1289           PERL_ARGS_ASSERT_GV_STASHPV;
1290 469819637         return gv_stashpvn(name, strlen(name), create);
1291           }
1292            
1293           /*
1294           =for apidoc gv_stashpvn
1295            
1296           Returns a pointer to the stash for a specified package. The C
1297           parameter indicates the length of the C, in bytes. C is passed
1298           to C, so if set to C then the package will be
1299           created if it does not already exist. If the package does not exist and
1300           C is 0 (or any other setting that does not create packages) then NULL
1301           is returned.
1302            
1303           Flags may be one of:
1304            
1305           GV_ADD
1306           SVf_UTF8
1307           GV_NOADD_NOINIT
1308           GV_NOINIT
1309           GV_NOEXPAND
1310           GV_ADDMG
1311            
1312           The most important of which are probably GV_ADD and SVf_UTF8.
1313            
1314           =cut
1315           */
1316            
1317           HV*
1318 587694165         Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1319           {
1320           char smallbuf[128];
1321           char *tmpbuf;
1322           HV *stash;
1323           GV *tmpgv;
1324 587694165         U32 tmplen = namelen + 2;
1325            
1326           PERL_ARGS_ASSERT_GV_STASHPVN;
1327            
1328 587694165 100       if (tmplen <= sizeof smallbuf)
1329           tmpbuf = smallbuf;
1330           else
1331 254         Newx(tmpbuf, tmplen, char);
1332 587694165         Copy(name, tmpbuf, namelen, char);
1333 587694165         tmpbuf[namelen] = ':';
1334 587694165         tmpbuf[namelen+1] = ':';
1335 587694165         tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1336 587694165 100       if (tmpbuf != smallbuf)
1337 254         Safefree(tmpbuf);
1338 587694165 100       if (!tmpgv)
1339           return NULL;
1340 587376741         stash = GvHV(tmpgv);
1341 587376741 100       if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1342           assert(stash);
1343 587376739 100       if (!HvNAME_get(stash)) {
    50        
    100        
    50        
    50        
    100        
    50        
1344 24         hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1345          
1346           /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1347           /* If the containing stash has multiple effective
1348           names, see that this one gets them, too. */
1349 24 100       if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1350 294033475         mro_package_moved(stash, NULL, tmpgv, 1);
1351           }
1352           return stash;
1353           }
1354            
1355           /*
1356           =for apidoc gv_stashsv
1357            
1358           Returns a pointer to the stash for a specified package. See C.
1359            
1360           =cut
1361           */
1362            
1363           HV*
1364 86599078         Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1365           {
1366           STRLEN len;
1367 86599078 100       const char * const ptr = SvPV_const(sv,len);
1368            
1369           PERL_ARGS_ASSERT_GV_STASHSV;
1370            
1371 86599078         return gv_stashpvn(ptr, len, flags | SvUTF8(sv));
1372           }
1373            
1374            
1375           GV *
1376 216167413         Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1377           PERL_ARGS_ASSERT_GV_FETCHPV;
1378 216167413         return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1379           }
1380            
1381           GV *
1382 113762471         Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1383           STRLEN len;
1384           const char * const nambeg =
1385 113762471 100       SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
    100        
1386           PERL_ARGS_ASSERT_GV_FETCHSV;
1387 113762471         return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1388           }
1389            
1390           STATIC void
1391 447134         S_gv_magicalize_isa(pTHX_ GV *gv)
1392           {
1393           AV* av;
1394            
1395           PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1396            
1397 447134 50       av = GvAVn(gv);
1398 447134         GvMULTI_on(gv);
1399 447134         sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1400           NULL, 0);
1401 447134         }
1402            
1403           GV *
1404 1001020195         Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
1405           const svtype sv_type)
1406           {
1407           dVAR;
1408           const char *name = nambeg;
1409           GV *gv = NULL;
1410           GV**gvp;
1411           STRLEN len;
1412           const char *name_cursor;
1413           HV *stash = NULL;
1414 1001020195         const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
1415 1001020195         const I32 no_expand = flags & GV_NOEXPAND;
1416 1001020195         const I32 add = flags & ~GV_NOADD_MASK;
1417 1001020195         const U32 is_utf8 = flags & SVf_UTF8;
1418 1001020195         bool addmg = !!(flags & GV_ADDMG);
1419 1001020195         const char *const name_end = nambeg + full_len;
1420 1001020195         const char *const name_em1 = name_end - 1;
1421           U32 faking_it;
1422            
1423           PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
1424            
1425 1001020195 100       if (flags & GV_NOTQUAL) {
1426           /* Caller promised that there is no stash, so we can skip the check. */
1427           len = full_len;
1428           goto no_stash;
1429           }
1430            
1431 993973298 100       if (full_len > 2 && *name == '*' && isIDFIRST_lazy_if(name + 1, is_utf8)) {
    100        
    100        
    50        
    0        
    0        
    0        
    50        
1432           /* accidental stringify on a GV? */
1433 30573908         name++;
1434           }
1435            
1436 8733801686 100       for (name_cursor = name; name_cursor < name_end; name_cursor++) {
1437 12290728444 100       if (name_cursor < name_em1 &&
    100        
1438 7941053554         ((*name_cursor == ':'
1439 1565107791 100       && name_cursor[1] == ':')
1440 6375949635 100       || *name_cursor == '\''))
1441           {
1442 1565103991 100       if (!stash)
1443 880303638         stash = PL_defstash;
1444 1565103991 50       if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
    50        
1445           return NULL;
1446            
1447 1565103991         len = name_cursor - name;
1448 1565103991 100       if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1449           const char *key;
1450 1564966125 100       if (*name_cursor == ':') {
1451           key = name;
1452 1564966055         len += 2;
1453           } else {
1454           char *tmpbuf;
1455 70         Newx(tmpbuf, len+2, char);
1456 70         Copy(name, tmpbuf, len, char);
1457 70         tmpbuf[len++] = ':';
1458 70         tmpbuf[len++] = ':';
1459           key = tmpbuf;
1460           }
1461 1564966125 100       gvp = (GV**)hv_fetch(stash, key, is_utf8 ? -len : len, add);
    100        
1462 1564966125 100       gv = gvp ? *gvp : NULL;
1463 1564966125 100       if (gv && gv != (const GV *)&PL_sv_undef) {
    50        
1464 1564615731 100       if (SvTYPE(gv) != SVt_PVGV)
1465 1600285         gv_init_pvn(gv, stash, key, len, (add & GV_ADDMULTI)|is_utf8);
1466           else
1467 1563015446         GvMULTI_on(gv);
1468           }
1469 1564966125 100       if (key != name)
1470 70         Safefree(key);
1471 1564966125 100       if (!gv || gv == (const GV *)&PL_sv_undef)
    50        
1472           return NULL;
1473            
1474 1564615731 100       if (!(stash = GvHV(gv)))
1475           {
1476 1600303         stash = GvHV(gv) = newHV();
1477 1600303 50       if (!HvNAME_get(stash)) {
    0        
    0        
    0        
    0        
    0        
    0        
1478 1600303 100       if (GvSTASH(gv) == PL_defstash && len == 6
1479 172462 100       && strnEQ(name, "CORE", 4))
1480 24346         hv_name_set(stash, "CORE", 4, 0);
1481           else
1482 1575957         hv_name_set(
1483           stash, nambeg, name_cursor-nambeg, is_utf8
1484           );
1485           /* If the containing stash has multiple effective
1486           names, see that this one gets them, too. */
1487 1600303 100       if (HvAUX(GvSTASH(gv))->xhv_name_count)
1488 190         mro_package_moved(stash, NULL, gv, 1);
1489           }
1490           }
1491 1563015428 100       else if (!HvNAME_get(stash))
    50        
    100        
    100        
    50        
    100        
    50        
1492 48         hv_name_set(stash, nambeg, name_cursor - nambeg, is_utf8);
1493           }
1494            
1495 1564753597 100       if (*name_cursor == ':')
1496 1564753529         name_cursor++;
1497 1564753597         name = name_cursor+1;
1498 1564753597 100       if (name == name_end)
1499 597234767         return gv
1500 597234767 100       ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1501           }
1502           }
1503 396388137         len = name_cursor - name;
1504            
1505           /* No stash in name, so see how we can default */
1506            
1507 396388137 100       if (!stash) {
1508           no_stash:
1509 120716557 100       if (len && isIDFIRST_lazy_if(name, is_utf8)) {
    100        
    100        
    100        
    100        
    100        
    50        
    100        
    100        
    100        
1510           bool global = FALSE;
1511            
1512 108256987         switch (len) {
1513           case 1:
1514 24041368 100       if (*name == '_')
1515           global = TRUE;
1516           break;
1517           case 3:
1518 7740322 100       if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
    100        
    50        
1519 7318506 100       || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
    100        
    100        
1520 6626553 100       || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
    100        
    50        
1521           global = TRUE;
1522           break;
1523           case 4:
1524 9395079 100       if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
    100        
    50        
1525 167734 100       && name[3] == 'V')
1526           global = TRUE;
1527           break;
1528           case 5:
1529 15107199 100       if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
    100        
    100        
1530 56152 50       && name[3] == 'I' && name[4] == 'N')
    50        
1531           global = TRUE;
1532           break;
1533           case 6:
1534 10316484 100       if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
    100        
    100        
1535 962572 100       &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
    50        
    50        
1536 883899 50       ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
    50        
    50        
1537           global = TRUE;
1538           break;
1539           case 7:
1540 12678201 100       if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
    100        
    50        
1541 316 100       && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
    50        
    50        
1542 216 50       && name[6] == 'T')
1543           global = TRUE;
1544           break;
1545           }
1546            
1547 108256987 100       if (global)
1548 27168232         stash = PL_defstash;
1549 81088755 100       else if (IN_PERL_COMPILETIME) {
1550 79755158         stash = PL_curstash;
1551 100932867 100       if (add && (PL_hints & HINT_STRICT_VARS) &&
    100        
1552 43520925         sv_type != SVt_PVCV &&
1553 4093893 100       sv_type != SVt_PVGV &&
1554 3500204 100       sv_type != SVt_PVFM &&
1555 1906654 100       sv_type != SVt_PVIO &&
1556 1156055 100       !(len == 1 && sv_type == SVt_PV &&
1557 263568         (*name == 'a' || *name == 'b')) )
1558           {
1559 1716488 100       gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,0);
1560 2517812 100       if (!gvp ||
    50        
1561 2517732 50       *gvp == (const GV *)&PL_sv_undef ||
1562 1716408         SvTYPE(*gvp) != SVt_PVGV)
1563           {
1564           stash = NULL;
1565           }
1566 1716408 100       else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
    100        
    100        
1567 990937 100       (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
    100        
1568 364462 100       (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1569           {
1570           /* diag_listed_as: Variable "%s" is not imported%s */
1571 319 100       Perl_ck_warner_d(
1572           aTHX_ packWARN(WARN_MISC),
1573           "Variable \"%c%"UTF8f"\" is not imported",
1574           sv_type == SVt_PVAV ? '@' :
1575 158 100       sv_type == SVt_PVHV ? '%' : '$',
1576           UTF8fARG(is_utf8, len, name));
1577 160 50       if (GvCVu(*gvp))
    50        
1578 0         Perl_ck_warner_d(
1579           aTHX_ packWARN(WARN_MISC),
1580           "\t(Did you mean &%"UTF8f" instead?)\n",
1581           UTF8fARG(is_utf8, len, name)
1582           );
1583           stash = NULL;
1584           }
1585           }
1586           }
1587           else
1588 1333597         stash = CopSTASH(PL_curcop);
1589           }
1590           else
1591 12459570         stash = PL_defstash;
1592           }
1593            
1594           /* By this point we should have a stash and a name */
1595            
1596 403435034 100       if (!stash) {
1597 486 100       if (add && !PL_in_clean_all) {
    50        
1598 367 100       SV * const err = Perl_mess(aTHX_
1599           "Global symbol \"%s%"UTF8f
1600           "\" requires explicit package name",
1601           (sv_type == SVt_PV ? "$"
1602           : sv_type == SVt_PVAV ? "@"
1603 8 100       : sv_type == SVt_PVHV ? "%"
1604 5 50       : ""), UTF8fARG(is_utf8, len, name));
1605           GV *gv;
1606 242 100       if (is_utf8)
1607 144         SvUTF8_on(err);
1608 242         qerror(err);
1609 242         gv = gv_fetchpvs("::", GV_ADDMULTI, SVt_PVHV);
1610 242 50       if(!gv) {
1611           /* symbol table under destruction */
1612           return NULL;
1613           }
1614 242         stash = GvHV(gv);
1615           }
1616           else
1617           return NULL;
1618           }
1619            
1620 403435032 50       if (!SvREFCNT(stash)) /* symbol table under destruction */
1621           return NULL;
1622            
1623 403435032 100       gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add);
    100        
1624 403435032 100       if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
    50        
1625 31357133 100       if (addmg) gv = (GV *)newSV(0);
1626           else return NULL;
1627           }
1628 372077899         else gv = *gvp, addmg = 0;
1629           /* From this point on, addmg means gv has not been inserted in the
1630           symtab yet. */
1631            
1632 372431671 100       if (SvTYPE(gv) == SVt_PVGV) {
1633 343715265 100       if (add) {
1634 91576626         GvMULTI_on(gv);
1635 91576626         gv_init_svtype(gv, sv_type);
1636           /* You reach this path once the typeglob has already been created,
1637           either by the same or a different sigil. If this path didn't
1638           exist, then (say) referencing $! first, and %! second would
1639           mean that %! was not handled correctly. */
1640 91576626 100       if (len == 1 && stash == PL_defstash) {
    100        
1641 16933283 100       if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
1642 474697 100       if (*name == '!')
1643 16282         require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1644 458415 100       else if (*name == '-' || *name == '+')
1645 6002         require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1646 16458586 100       } else if (sv_type == SVt_PV) {
1647 7394894 100       if (*name == '*' || *name == '#') {
1648           /* diag_listed_as: $* is no longer supported */
1649 34         Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
1650           WARN_SYNTAX),
1651 34         "$%c is no longer supported", *name);
1652           }
1653           }
1654 16933177 100       if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
1655 7670891 100       switch (*name) {
1656           case '[':
1657 630         require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
1658 630         break;
1659           #ifdef PERL_SAWAMPERSAND
1660           case '`':
1661           PL_sawampersand |= SAWAMPERSAND_LEFT;
1662           (void)GvSVn(gv);
1663           break;
1664           case '&':
1665           PL_sawampersand |= SAWAMPERSAND_MIDDLE;
1666           (void)GvSVn(gv);
1667           break;
1668           case '\'':
1669           PL_sawampersand |= SAWAMPERSAND_RIGHT;
1670           (void)GvSVn(gv);
1671           break;
1672           #endif
1673           }
1674           }
1675           }
1676 74643343 100       else if (len == 3 && sv_type == SVt_PVAV
1677 327410 100       && strnEQ(name, "ISA", 3)
1678 128195 50       && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
    50        
1679 0         gv_magicalize_isa(gv);
1680           }
1681           return gv;
1682 28716406 100       } else if (no_init) {
1683           assert(!addmg);
1684           return gv;
1685 26242792 100       } else if (no_expand && SvROK(gv)) {
    100        
1686           assert(!addmg);
1687           return gv;
1688           }
1689            
1690           /* Adding a new symbol.
1691           Unless of course there was already something non-GV here, in which case
1692           we want to behave as if there was always a GV here, containing some sort
1693           of subroutine.
1694           Otherwise we run the risk of creating things like GvIO, which can cause
1695           subtle bugs. eg the one that tripped up SQL::Translator */
1696            
1697 25559034 100       faking_it = SvOK(gv);
    50        
    50        
1698            
1699 25559034 50       if (add & GV_ADDWARN)
1700 0         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1701           "Had to create %"UTF8f" unexpectedly",
1702 0         UTF8fARG(is_utf8, name_end-nambeg, nambeg));
1703 25559034         gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
1704            
1705 50407988 100       if ( isIDFIRST_lazy_if(name, is_utf8)
1706 62586402 100       && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) )
    100        
    100        
    50        
    50        
    100        
    100        
1707 17422226         GvMULTI_on(gv) ;
1708            
1709           /* set up magic where warranted */
1710 25559014 100       if (stash != PL_defstash) { /* not the main stash */
1711           /* We only have to check for three names here: EXPORT, ISA
1712           and VERSION. All the others apply only to the main stash or to
1713           CORE (which is checked right after this). */
1714 24357756 100       if (len > 2) {
1715 23851477         const char * const name2 = name + 1;
1716 23851477         switch (*name) {
1717           case 'E':
1718 1134123 100       if (strnEQ(name2, "XPORT", 5))
1719 363726         GvMULTI_on(gv);
1720           break;
1721           case 'I':
1722 682506 100       if (strEQ(name2, "SA"))
    100        
    100        
1723 447090         gv_magicalize_isa(gv);
1724           break;
1725           case 'V':
1726 665063 100       if (strEQ(name2, "ERSION"))
1727 586999         GvMULTI_on(gv);
1728           break;
1729           default:
1730           goto try_core;
1731           }
1732           goto add_magical_gv;
1733           }
1734           try_core:
1735 21876064 100       if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
    50        
    50        
    100        
    100        
    100        
    100        
1736           /* Avoid null warning: */
1737 1679588 50       const char * const stashname = HvNAME(stash); assert(stashname);
    50        
    100        
    50        
    50        
    100        
1738 1679588 100       if (strnEQ(stashname, "CORE", 4))
1739 926         S_maybe_add_coresub(aTHX_ 0, gv, name, len);
1740           }
1741           }
1742 1201258 100       else if (len > 1) {
1743           #ifndef EBCDIC
1744 709688 100       if (*name > 'V' ) {
1745           NOOP;
1746           /* Nothing else to do.
1747           The compiler will probably turn the switch statement into a
1748           branch table. Make sure we avoid even that small overhead for
1749           the common case of lower case variable names. (On EBCDIC
1750           platforms, we can't just do:
1751           if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) {
1752           because cases like '\027' in the switch statement below are
1753           C1 (non-ASCII) controls on those platforms, so the remapping
1754           would make them larger than 'V')
1755           */
1756           } else
1757           #endif
1758           {
1759 308756         const char * const name2 = name + 1;
1760 308756         switch (*name) {
1761           case 'A':
1762 32008 100       if (strEQ(name2, "RGV")) {
    100        
    100        
    100        
1763 24228 50       IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
    50        
    50        
    50        
1764           }
1765 7780 100       else if (strEQ(name2, "RGVOUT")) {
1766 212         GvMULTI_on(gv);
1767           }
1768           break;
1769           case 'E':
1770 27932 50       if (strnEQ(name2, "XPORT", 5))
1771 0         GvMULTI_on(gv);
1772           break;
1773           case 'I':
1774 28762 100       if (strEQ(name2, "SA")) {
    100        
    100        
1775 44         gv_magicalize_isa(gv);
1776           }
1777           break;
1778           case 'S':
1779 93930 100       if (strEQ(name2, "IG")) {
    50        
    100        
1780           HV *hv;
1781           I32 i;
1782 16146 100       if (!PL_psig_name) {
1783 16108         Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1784 16108         Newxz(PL_psig_pend, SIG_SIZE, int);
1785 16108         PL_psig_ptr = PL_psig_name + SIG_SIZE;
1786           } else {
1787           /* I think that the only way to get here is to re-use an
1788           embedded perl interpreter, where the previous
1789           use didn't clean up fully because
1790           PL_perl_destruct_level was 0. I'm not sure that we
1791           "support" that, in that I suspect in that scenario
1792           there are sufficient other garbage values left in the
1793           interpreter structure that something else will crash
1794           before we get here. I suspect that this is one of
1795           those "doctor, it hurts when I do this" bugs. */
1796 38         Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1797 38         Zero(PL_psig_pend, SIG_SIZE, int);
1798           }
1799 16146         GvMULTI_on(gv);
1800 16146 50       hv = GvHVn(gv);
1801 16146         hv_magic(hv, NULL, PERL_MAGIC_sig);
1802 1114074 100       for (i = 1; i < SIG_SIZE; i++) {
1803 1097928         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1804 1097928 50       if (init)
1805 1097928         sv_setsv(*init, &PL_sv_undef);
1806           }
1807           }
1808           break;
1809           case 'V':
1810 1642 100       if (strEQ(name2, "ERSION"))
1811 896         GvMULTI_on(gv);
1812           break;
1813           case '\003': /* $^CHILD_ERROR_NATIVE */
1814 6 50       if (strEQ(name2, "HILD_ERROR_NATIVE"))
1815           goto magicalize;
1816           break;
1817           case '\005': /* $^ENCODING */
1818 248 50       if (strEQ(name2, "NCODING"))
1819           goto magicalize;
1820           break;
1821           case '\007': /* $^GLOBAL_PHASE */
1822 4 50       if (strEQ(name2, "LOBAL_PHASE"))
1823           goto ro_magicalize;
1824           break;
1825           case '\014': /* $^LAST_FH */
1826 2 50       if (strEQ(name2, "AST_FH"))
1827           goto ro_magicalize;
1828           break;
1829           case '\015': /* $^MATCH */
1830 6 100       if (strEQ(name2, "ATCH"))
1831           goto magicalize;
1832           break;
1833           case '\017': /* $^OPEN */
1834 404 50       if (strEQ(name2, "PEN"))
    50        
    50        
    50        
1835           goto magicalize;
1836           break;
1837           case '\020': /* $^PREMATCH $^POSTMATCH */
1838 202 100       if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
    50        
1839           goto magicalize;
1840           break;
1841           case '\024': /* ${^TAINT} */
1842 9876 50       if (strEQ(name2, "AINT"))
1843           goto ro_magicalize;
1844           break;
1845           case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
1846 754 100       if (strEQ(name2, "NICODE"))
1847           goto ro_magicalize;
1848 274 100       if (strEQ(name2, "TF8LOCALE"))
1849           goto ro_magicalize;
1850 16 50       if (strEQ(name2, "TF8CACHE"))
1851           goto magicalize;
1852           break;
1853           case '\027': /* $^WARNING_BITS */
1854 18494 50       if (strEQ(name2, "ARNING_BITS"))
1855           goto magicalize;
1856           break;
1857           case '1':
1858           case '2':
1859           case '3':
1860           case '4':
1861           case '5':
1862           case '6':
1863           case '7':
1864           case '8':
1865           case '9':
1866           {
1867           /* Ensures that we have an all-digit variable, ${"1foo"} fails
1868           this test */
1869           /* This snippet is taken from is_gv_magical */
1870 60         const char *end = name + len;
1871 168 100       while (--end > name) {
1872 88 100       if (!isDIGIT(*end)) goto add_magical_gv;
1873           }
1874           goto magicalize;
1875           }
1876           }
1877           }
1878           } else {
1879           /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1880           be case '\0' in this switch statement (ie a default case) */
1881 491570         switch (*name) {
1882           case '&': /* $& */
1883           case '`': /* $` */
1884           case '\'': /* $' */
1885           #ifdef PERL_SAWAMPERSAND
1886           if (!(
1887           sv_type == SVt_PVAV ||
1888           sv_type == SVt_PVHV ||
1889           sv_type == SVt_PVCV ||
1890           sv_type == SVt_PVFM ||
1891           sv_type == SVt_PVIO
1892           )) { PL_sawampersand |=
1893           (*name == '`')
1894           ? SAWAMPERSAND_LEFT
1895           : (*name == '&')
1896           ? SAWAMPERSAND_MIDDLE
1897           : SAWAMPERSAND_RIGHT;
1898           }
1899           #endif
1900           goto magicalize;
1901            
1902           case ':': /* $: */
1903 1504 50       sv_setpv(GvSVn(gv),PL_chopset);
1904 1504         goto magicalize;
1905            
1906           case '?': /* $? */
1907           #ifdef COMPLEX_STATUS
1908           SvUPGRADE(GvSVn(gv), SVt_PVLV);
1909           #endif
1910           goto magicalize;
1911            
1912           case '!': /* $! */
1913 18486         GvMULTI_on(gv);
1914           /* If %! has been used, automatically load Errno.pm. */
1915            
1916 18486 50       sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1917            
1918           /* magicalization must be done before require_tie_mod is called */
1919 18486 50       if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1920           {
1921 0 0       if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1922           addmg = 0;
1923 0         require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1924           }
1925            
1926           break;
1927           case '-': /* $- */
1928           case '+': /* $+ */
1929 3794         GvMULTI_on(gv); /* no used once warnings here */
1930           {
1931 3794 50       AV* const av = GvAVn(gv);
1932 3794 100       SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1933            
1934 3794         sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1935 3794 50       sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1936 3794 100       if (avc)
1937 1896 50       SvREADONLY_on(GvSVn(gv));
1938 3794         SvREADONLY_on(av);
1939            
1940 3794 100       if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1941           {
1942 808 100       if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1943           addmg = 0;
1944 808         require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1945           }
1946            
1947           break;
1948           }
1949           case '*': /* $* */
1950           case '#': /* $# */
1951 32 100       if (sv_type == SVt_PV)
1952           /* diag_listed_as: $* is no longer supported */
1953 26         Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1954 26         "$%c is no longer supported", *name);
1955           break;
1956           case '\010': /* $^H */
1957           {
1958 24346 50       HV *const hv = GvHVn(gv);
1959 24346         hv_magic(hv, NULL, PERL_MAGIC_hints);
1960           }
1961 24346         goto magicalize;
1962           case '[': /* $[ */
1963 362 50       if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
    100        
    50        
    50        
1964 361 100       && FEATURE_ARYBASE_IS_ENABLED) {
    50        
    100        
    0        
    50        
    50        
1965 232 100       if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1966 232         require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
1967           addmg = 0;
1968           }
1969           else goto magicalize;
1970 232         break;
1971           case '\023': /* $^S */
1972           ro_magicalize:
1973 10826 50       SvREADONLY_on(GvSVn(gv));
1974           /* FALL THROUGH */
1975           case '0': /* $0 */
1976           case '1': /* $1 */
1977           case '2': /* $2 */
1978           case '3': /* $3 */
1979           case '4': /* $4 */
1980           case '5': /* $5 */
1981           case '6': /* $6 */
1982           case '7': /* $7 */
1983           case '8': /* $8 */
1984           case '9': /* $9 */
1985           case '^': /* $^ */
1986           case '~': /* $~ */
1987           case '=': /* $= */
1988           case '%': /* $% */
1989           case '.': /* $. */
1990           case '(': /* $( */
1991           case ')': /* $) */
1992           case '<': /* $< */
1993           case '>': /* $> */
1994           case '\\': /* $\ */
1995           case '/': /* $/ */
1996           case '|': /* $| */
1997           case '$': /* $$ */
1998           case '\001': /* $^A */
1999           case '\003': /* $^C */
2000           case '\004': /* $^D */
2001           case '\005': /* $^E */
2002           case '\006': /* $^F */
2003           case '\011': /* $^I, NOT \t in EBCDIC */
2004           case '\016': /* $^N */
2005           case '\017': /* $^O */
2006           case '\020': /* $^P */
2007           case '\024': /* $^T */
2008           case '\027': /* $^W */
2009           magicalize:
2010 286278 100       sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2011 286278         break;
2012            
2013           case '\014': /* $^L */
2014 1498 50       sv_setpvs(GvSVn(gv),"\f");
2015 1498         break;
2016           case ';': /* $; */
2017 2602 50       sv_setpvs(GvSVn(gv),"\034");
2018 2602         break;
2019           case ']': /* $] */
2020           {
2021 16736         SV * const sv = GvSV(gv);
2022 16736 100       if (!sv_derived_from(PL_patchlevel, "version"))
2023 474         upg_version(PL_patchlevel, TRUE);
2024 16736         GvSV(gv) = vnumify(PL_patchlevel);
2025 16736         SvREADONLY_on(GvSV(gv));
2026 16736         SvREFCNT_dec(sv);
2027           }
2028 16736         break;
2029           case '\026': /* $^V */
2030           {
2031 11864         SV * const sv = GvSV(gv);
2032 11864         GvSV(gv) = new_version(PL_patchlevel);
2033 11864         SvREADONLY_on(GvSV(gv));
2034 11864         SvREFCNT_dec(sv);
2035           }
2036 11864         break;
2037           }
2038           }
2039           add_magical_gv:
2040 25559014 100       if (addmg) {
2041 528178 100       if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
    50        
    50        
    50        
    50        
    50        
    100        
    100        
2042 174480 100       GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
    50        
    50        
    50        
2043           ))
2044 1060         (void)hv_store(stash,name,len,(SV *)gv,0);
2045 352708         else SvREFCNT_dec_NN(gv), gv = NULL;
2046           }
2047 515439947 100       if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
    100        
2048           return gv;
2049           }
2050            
2051           void
2052 5136007         Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2053           {
2054           const char *name;
2055 5136007         const HV * const hv = GvSTASH(gv);
2056            
2057           PERL_ARGS_ASSERT_GV_FULLNAME4;
2058            
2059 5136007 100       sv_setpv(sv, prefix ? prefix : "");
2060            
2061 5136007 100       if (hv && (name = HvNAME(hv))) {
    50        
    50        
    100        
    100        
    50        
    100        
    100        
2062 5135983 50       const STRLEN len = HvNAMELEN(hv);
    50        
    100        
    50        
    50        
    100        
2063 5135983 100       if (keepmain || strnNE(name, "main", len)) {
    50        
    0        
    100        
2064 5135049 50       sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
    50        
    100        
    50        
    50        
    100        
    100        
    100        
2065 5135049         sv_catpvs(sv,"::");
2066           }
2067           }
2068 24         else sv_catpvs(sv,"__ANON__::");
2069 5136007         sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2070 5136007         }
2071            
2072           void
2073 5135097         Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2074           {
2075 5135097 50       const GV * const egv = GvEGVx(gv);
    50        
2076            
2077           PERL_ARGS_ASSERT_GV_EFULLNAME4;
2078            
2079 5135097 100       gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2080 5135097         }
2081            
2082           void
2083 1329382         Perl_gv_check(pTHX_ HV *stash)
2084           {
2085           dVAR;
2086           I32 i;
2087            
2088           PERL_ARGS_ASSERT_GV_CHECK;
2089            
2090 1329382 50       if (!HvARRAY(stash))
2091 1329382         return;
2092 35271467 100       for (i = 0; i <= (I32) HvMAX(stash); i++) {
2093           const HE *entry;
2094           /* SvIsCOW is unused on HVs, so we can use it to mark stashes we
2095           are currently searching through recursively. */
2096 34578336         SvIsCOW_on(stash);
2097 54796406 100       for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2098           GV *gv;
2099           HV *hv;
2100 20855003 100       if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
    50        
2101 1967679 100       (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
    100        
2102           {
2103 1329384 100       if (hv != PL_defstash && hv != stash && !SvIsCOW(hv))
    100        
2104 1311512         gv_check(hv); /* nested package */
2105           }
2106 18888686 100       else if ( *HeKEY(entry) != '_'
2107 17012686 50       && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
    50        
    0        
    100        
    100        
    50        
    0        
    0        
    100        
2108           const char *file;
2109 16291988         gv = MUTABLE_GV(HeVAL(entry));
2110 16291988 100       if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
    100        
2111 16291868         continue;
2112 120 50       file = GvFILE(gv);
2113 120         CopLINE_set(PL_curcop, GvLINE(gv));
2114           #ifdef USE_ITHREADS
2115           CopFILE(PL_curcop) = (char *)file; /* set for warning */
2116           #else
2117 120         CopFILEGV(PL_curcop)
2118 120         = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2119           #endif
2120 300 50       Perl_warner(aTHX_ packWARN(WARN_ONCE),
    50        
2121           "Name \"%"HEKf"::%"HEKf
2122           "\" used only once: possible typo",
2123 240 50       HEKfARG(HvNAME_HEK(stash)),
2124 120         HEKfARG(GvNAME_HEK(gv)));
2125           }
2126           }
2127 34578336         SvIsCOW_off(stash);
2128           }
2129           }
2130            
2131           GV *
2132 394         Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2133           {
2134           dVAR;
2135           PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2136           assert(!(flags & ~SVf_UTF8));
2137            
2138 394         return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld",
2139           UTF8fARG(flags, strlen(pack), pack),
2140           (long)PL_gensym++),
2141           GV_ADD, SVt_PVGV);
2142           }
2143            
2144           /* hopefully this is only called on local symbol table entries */
2145            
2146           GP*
2147 44425602         Perl_gp_ref(pTHX_ GP *gp)
2148           {
2149           dVAR;
2150 44425602 50       if (!gp)
2151           return NULL;
2152 44425602         gp->gp_refcnt++;
2153 44425602 100       if (gp->gp_cv) {
2154 19907184 100       if (gp->gp_cvgen) {
2155           /* If the GP they asked for a reference to contains
2156           a method cache entry, clear it first, so that we
2157           don't infect them with our cached entry */
2158 10         SvREFCNT_dec_NN(gp->gp_cv);
2159 10         gp->gp_cv = NULL;
2160 22219551         gp->gp_cvgen = 0;
2161           }
2162           }
2163           return gp;
2164           }
2165            
2166           void
2167 82319239         Perl_gp_free(pTHX_ GV *gv)
2168           {
2169           dVAR;
2170           GP* gp;
2171           int attempts = 100;
2172            
2173 82319239 50       if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
    50        
    50        
    100        
2174           return;
2175 54907563 50       if (gp->gp_refcnt == 0) {
2176 0         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2177           "Attempt to free unreferenced glob pointers"
2178           pTHX__FORMAT pTHX__VALUE);
2179 0         return;
2180           }
2181 54907563 100       if (--gp->gp_refcnt > 0) {
2182 44346778 100       if (gp->gp_egv == gv)
2183 345337         gp->gp_egv = 0;
2184 44346778         GvGP_set(gv, NULL);
2185 44346779         return;
2186           }
2187            
2188           while (1) {
2189           /* Copy and null out all the glob slots, so destructors do not see
2190           freed SVs. */
2191 10560787         HEK * const file_hek = gp->gp_file_hek;
2192 10560787         SV * const sv = gp->gp_sv;
2193 10560787         AV * const av = gp->gp_av;
2194 10560787         HV * const hv = gp->gp_hv;
2195 10560787         IO * const io = gp->gp_io;
2196 10560787         CV * const cv = gp->gp_cv;
2197 10560787         CV * const form = gp->gp_form;
2198            
2199 10560787         gp->gp_file_hek = NULL;
2200 10560787         gp->gp_sv = NULL;
2201 10560787         gp->gp_av = NULL;
2202 10560787         gp->gp_hv = NULL;
2203 10560787         gp->gp_io = NULL;
2204 10560787         gp->gp_cv = NULL;
2205 10560787         gp->gp_form = NULL;
2206            
2207 10560787 100       if (file_hek)
2208 10560163         unshare_hek(file_hek);
2209            
2210 10560787         SvREFCNT_dec(sv);
2211 10560787         SvREFCNT_dec(av);
2212           /* FIXME - another reference loop GV -> symtab -> GV ?
2213           Somehow gp->gp_hv can end up pointing at freed garbage. */
2214 10560787 100       if (hv && SvTYPE(hv) == SVt_PVHV) {
    50        
2215 31684 100       const HEK *hvname_hek = HvNAME_HEK(hv);
    100        
    100        
2216           DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", hvname_hek));
2217 31684 100       if (PL_stashcache && hvname_hek)
2218 778 100       (void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek),
2219           (HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) : HEK_LEN(hvname_hek)),
2220           G_DISCARD);
2221 31684         SvREFCNT_dec(hv);
2222           }
2223 10560787         SvREFCNT_dec(io);
2224 10560785         SvREFCNT_dec(cv);
2225 10560783         SvREFCNT_dec(form);
2226            
2227 10560783 50       if (!gp->gp_file_hek
2228 10560783 100       && !gp->gp_sv
2229 10560781 50       && !gp->gp_av
2230 10560781 50       && !gp->gp_hv
2231 10560781 50       && !gp->gp_io
2232 10560781 50       && !gp->gp_cv
2233 10560781 50       && !gp->gp_form) break;
2234            
2235 2 50       if (--attempts == 0) {
2236 0         Perl_die(aTHX_
2237           "panic: gp_free failed to free glob pointer - "
2238           "something is repeatedly re-creating entries"
2239           );
2240           }
2241           }
2242            
2243 10560781         Safefree(gp);
2244 46445674         GvGP_set(gv, NULL);
2245           }
2246            
2247           int
2248 364156         Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2249           {
2250 364156         AMT * const amtp = (AMT*)mg->mg_ptr;
2251           PERL_UNUSED_ARG(sv);
2252            
2253           PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2254            
2255 364156 50       if (amtp && AMT_AMAGIC(amtp)) {
    100        
2256           int i;
2257 523125 100       for (i = 1; i < NofAMmeth; i++) {
2258 519250         CV * const cv = amtp->table[i];
2259 519250 100       if (cv) {
2260 122132         SvREFCNT_dec_NN(MUTABLE_SV(cv));
2261 122132         amtp->table[i] = NULL;
2262           }
2263           }
2264           }
2265 364156         return 0;
2266           }
2267            
2268           /* Updates and caches the CV's */
2269           /* Returns:
2270           * 1 on success and there is some overload
2271           * 0 if there is no overload
2272           * -1 if some error occurred and it couldn't croak
2273           */
2274            
2275           int
2276 5459893         Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2277           {
2278           dVAR;
2279 5459893         MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2280           AMT amt;
2281 5459893 100       const struct mro_meta* stash_meta = HvMROMETA(stash);
2282           U32 newgen;
2283            
2284           PERL_ARGS_ASSERT_GV_AMUPDATE;
2285            
2286 5459893         newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2287 5459893 100       if (mg) {
2288 5296844         const AMT * const amtp = (AMT*)mg->mg_ptr;
2289 5296844 100       if (amtp->was_ok_sub == newgen) {
2290 4932706         return AMT_AMAGIC(amtp) ? 1 : 0;
2291           }
2292 364138         sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2293           }
2294            
2295           DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2296            
2297           Zero(&amt,1,AMT);
2298 527187         amt.was_ok_sub = newgen;
2299 527187         amt.fallback = AMGfallNO;
2300 527187         amt.flags = 0;
2301            
2302           {
2303           int filled = 0;
2304           int i;
2305            
2306           /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2307            
2308           /* Try to find via inheritance. */
2309 527187         GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2310 527187 100       SV * const sv = gv ? GvSV(gv) : NULL;
2311           CV* cv;
2312            
2313 527187 100       if (!gv)
2314           {
2315 507379 100       if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
2316           goto no_table;
2317           }
2318           #ifdef PERL_DONT_CREATE_GVSV
2319 19808 100       else if (!sv) {
2320           NOOP; /* Equivalent to !SvTRUE and !SvOK */
2321           }
2322           #endif
2323 402 50       else if (SvTRUE(sv))
    50        
    0        
    100        
    50        
    50        
    100        
    50        
    100        
    50        
    50        
    50        
    50        
    50        
    100        
    50        
    0        
    100        
    0        
2324           /* don't need to set overloading here because fallback => 1
2325           * is the default setting for classes without overloading */
2326 10649         amt.fallback=AMGfallYES;
2327 24 100       else if (SvOK(sv)) {
    50        
    50        
2328 8         amt.fallback=AMGfallNEVER;
2329 8         filled = 1;
2330           }
2331           else {
2332           filled = 1;
2333           }
2334            
2335 1387980 100       for (i = 1; i < NofAMmeth; i++) {
2336 1377520         const char * const cooky = PL_AMG_names[i];
2337           /* Human-readable form, for debugging: */
2338 1377520         const char * const cp = AMG_id2name(i);
2339 1377520         const STRLEN l = PL_AMG_namelens[i];
2340            
2341           DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2342           cp, HvNAME_get(stash)) );
2343           /* don't fill the cache while looking up!
2344           Creation of inheritance stubs in intermediate packages may
2345           conflict with the logic of runtime method substitution.
2346           Indeed, for inheritance A -> B -> C, if C overloads "+0",
2347           then we could have created stubs for "(+0" in A and C too.
2348           But if B overloads "bool", we may want to use it for
2349           numifying instead of C's "+0". */
2350 1377520         gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2351           cv = 0;
2352 1377520 100       if (gv && (cv = GvCV(gv))) {
    50        
2353 432024 100       if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
    100        
    50        
    50        
    100        
2354 3145 50       const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
    50        
    50        
    0        
    50        
    50        
2355 2405 50       if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
    50        
    50        
    50        
    50        
2356 370 50       && strEQ(hvname, "overload")) {
2357           /* This is a hack to support autoloading..., while
2358           knowing *which* methods were declared as overloaded. */
2359           /* GvSV contains the name of the method. */
2360           GV *ngv = NULL;
2361 370         SV *gvsv = GvSV(gv);
2362            
2363           DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2364           "\" for overloaded \"%s\" in package \"%.256s\"\n",
2365           (void*)GvSV(gv), cp, HvNAME(stash)) );
2366 370 50       if (!gvsv || !SvPOK(gvsv)
    50        
2367 370 50       || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2368           {
2369           /* Can be an import stub (created by "can"). */
2370 0 0       if (destructing) {
2371           return -1;
2372           }
2373           else {
2374 0 0       const SV * const name = (gvsv && SvPOK(gvsv))
2375           ? gvsv
2376 0 0       : newSVpvs_flags("???", SVs_TEMP);
2377           /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2378 0 0       Perl_croak(aTHX_ "%s method \"%"SVf256
    0        
    0        
2379           "\" overloading \"%s\" "\
2380           "in package \"%"HEKf256"\"",
2381 0         (GvCVGEN(gv) ? "Stub found while resolving"
2382           : "Can't resolve"),
2383           SVfARG(name), cp,
2384 0 0       HEKfARG(
2385           HvNAME_HEK(stash)
2386           ));
2387           }
2388           }
2389 370         cv = GvCV(gv = ngv);
2390           }
2391           }
2392           DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2393           cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2394           GvNAME(CvGV(cv))) );
2395           filled = 1;
2396 1062346 50       } else if (gv) { /* Autoloaded... */
2397           cv = MUTABLE_CV(gv);
2398           filled = 1;
2399           }
2400 1377520         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2401           }
2402 20560 100       if (filled) {
2403 20554         AMT_AMAGIC_on(&amt);
2404 20554         sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2405           (char*)&amt, sizeof(AMT));
2406 20554         return TRUE;
2407           }
2408           }
2409           /* Here we have no table: */
2410           no_table:
2411 506633         AMT_AMAGIC_off(&amt);
2412 506633         sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2413           (char*)&amt, sizeof(AMTS));
2414 2983623         return 0;
2415           }
2416            
2417            
2418           CV*
2419 0         Perl_gv_handler(pTHX_ HV *stash, I32 id)
2420           {
2421           dVAR;
2422           MAGIC *mg;
2423           AMT *amtp;
2424           U32 newgen;
2425           struct mro_meta* stash_meta;
2426            
2427 0 0       if (!stash || !HvNAME_get(stash))
    0        
    0        
    0        
    0        
    0        
    0        
    0        
2428           return NULL;
2429            
2430 0 0       stash_meta = HvMROMETA(stash);
2431 0         newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2432            
2433 0         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2434 0 0       if (!mg) {
2435           do_update:
2436 0 0       if (Gv_AMupdate(stash, 0) == -1)
2437           return NULL;
2438 0         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2439           }
2440           assert(mg);
2441 0         amtp = (AMT*)mg->mg_ptr;
2442 0 0       if ( amtp->was_ok_sub != newgen )
2443           goto do_update;
2444 0 0       if (AMT_AMAGIC(amtp)) {
2445 0         CV * const ret = amtp->table[id];
2446 0 0       if (ret && isGV(ret)) { /* Autoloading stab */
    0        
2447           /* Passing it through may have resulted in a warning
2448           "Inherited AUTOLOAD for a non-method deprecated", since
2449           our caller is going through a function call, not a method call.
2450           So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2451 0         GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2452            
2453 0 0       if (gv && GvCV(gv))
    0        
2454 0         return GvCV(gv);
2455           }
2456           return ret;
2457           }
2458            
2459           return NULL;
2460           }
2461            
2462            
2463           /* Implement tryAMAGICun_MG macro.
2464           Do get magic, then see if the stack arg is overloaded and if so call it.
2465           Flags:
2466           AMGf_set return the arg using SETs rather than assigning to
2467           the targ
2468           AMGf_numeric apply sv_2num to the stack arg.
2469           */
2470            
2471           bool
2472 3276207 100       Perl_try_amagic_un(pTHX_ int method, int flags) {
2473           dVAR;
2474 2184138         dSP;
2475           SV* tmpsv;
2476 2184138         SV* const arg = TOPs;
2477            
2478 1099879         SvGETMAGIC(arg);
2479            
2480 2184138 100       if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
    100        
    100        
    100        
2481           AMGf_noright | AMGf_unary))) {
2482 7136 100       if (flags & AMGf_set) {
2483 42         SETs(tmpsv);
2484           }
2485           else {
2486 7094         dTARGET;
2487 7094 100       if (SvPADMY(TARG)) {
2488 246         sv_setsv(TARG, tmpsv);
2489 246 50       SETTARG;
2490           }
2491           else
2492 6848         SETs(tmpsv);
2493           }
2494 7136         PUTBACK;
2495 7136         return TRUE;
2496           }
2497            
2498 2176978 100       if ((flags & AMGf_numeric) && SvROK(arg))
    100        
2499 1092069         *sp = sv_2num(arg);
2500           return FALSE;
2501           }
2502            
2503            
2504           /* Implement tryAMAGICbin_MG macro.
2505           Do get magic, then see if the two stack args are overloaded and if so
2506           call it.
2507           Flags:
2508           AMGf_set return the arg using SETs rather than assigning to
2509           the targ
2510           AMGf_assign op may be called as mutator (eg +=)
2511           AMGf_numeric apply sv_2num to the stack arg.
2512           */
2513            
2514           bool
2515 14702824 100       Perl_try_amagic_bin(pTHX_ int method, int flags) {
2516           dVAR;
2517 9834277         dSP;
2518 9834277         SV* const left = TOPm1s;
2519 9834277         SV* const right = TOPs;
2520            
2521 10442455         SvGETMAGIC(left);
2522 14701979 100       if (left != right)
    100        
2523 6173616         SvGETMAGIC(right);
2524            
2525 9834271 100       if (SvAMAGIC(left) || SvAMAGIC(right)) {
    100        
    100        
    100        
    100        
    100        
2526 763216 100       SV * const tmpsv = amagic_call(left, right, method,
    100        
2527           ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2528 763058 100       if (tmpsv) {
2529 473394 100       if (flags & AMGf_set) {
2530 433414         (void)POPs;
2531 433414         SETs(tmpsv);
2532           }
2533           else {
2534 39980 100       dATARGET;
2535 39980         (void)POPs;
2536 39980 100       if (opASSIGN || SvPADMY(TARG)) {
    100        
2537 16878         sv_setsv(TARG, tmpsv);
2538 16878 50       SETTARG;
2539           }
2540           else
2541 23102         SETs(tmpsv);
2542           }
2543 473394         PUTBACK;
2544 473394         return TRUE;
2545           }
2546           }
2547 9361101 100       if(left==right && SvGMAGICAL(left)) {
    100        
    50        
2548 382         SV * const left = sv_newmortal();
2549 382         *(sp-1) = left;
2550           /* Print the uninitialized warning now, so it includes the vari-
2551           able name. */
2552 382 100       if (!SvOK(right)) {
    50        
    50        
2553 8 100       if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2554 8         sv_setsv_flags(left, &PL_sv_no, 0);
2555           }
2556 374         else sv_setsv_flags(left, right, 0);
2557 573         SvGETMAGIC(right);
2558           }
2559 9360719 100       if (flags & AMGf_numeric) {
2560 2388554 100       if (SvROK(TOPm1s))
2561 2332614         *(sp-1) = sv_2num(TOPm1s);
2562 2388554 100       if (SvROK(right))
2563 6133216         *sp = sv_2num(right);
2564           }
2565           return FALSE;
2566           }
2567            
2568           SV *
2569 4751179         Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2570           SV *tmpsv = NULL;
2571            
2572           PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2573            
2574 7126538 100       while (SvAMAGIC(ref) &&
    100        
    100        
    100        
2575           (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2576           AMGf_noright | AMGf_unary))) {
2577 4750615 100       if (!SvROK(tmpsv))
2578 60         Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2579 4750555 100       if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
    100        
2580           /* Bail out if it returns us the same reference. */
2581           return tmpsv;
2582           }
2583           ref = tmpsv;
2584           }
2585 2376804 100       return tmpsv ? tmpsv : ref;
2586           }
2587            
2588           bool
2589 15278066         Perl_amagic_is_enabled(pTHX_ int method)
2590           {
2591 15278066         SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2592            
2593           assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
2594            
2595 15278066 50       if ( !lex_mask || !SvOK(lex_mask) )
    100        
    50        
    50        
2596           /* overloading lexically disabled */
2597           return FALSE;
2598 52 50       else if ( lex_mask && SvPOK(lex_mask) ) {
    50        
2599           /* we have an entry in the hints hash, check if method has been
2600           * masked by overloading.pm */
2601           STRLEN len;
2602 52         const int offset = method / 8;
2603 52         const int bit = method % 8;
2604 52 50       char *pv = SvPV(lex_mask, len);
2605            
2606           /* Bit set, so this overloading operator is disabled */
2607 52 100       if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
    100        
2608           return FALSE;
2609           }
2610 7639049         return TRUE;
2611           }
2612            
2613           SV*
2614 20732645         Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2615           {
2616           dVAR;
2617           MAGIC *mg;
2618           CV *cv=NULL;
2619           CV **cvp=NULL, **ocvp=NULL;
2620           AMT *amtp=NULL, *oamtp=NULL;
2621           int off = 0, off1, lr = 0, notfound = 0;
2622           int postpr = 0, force_cpy = 0;
2623 20732645         int assign = AMGf_assign & flags;
2624 20732645         const int assignshift = assign ? 1 : 0;
2625           int use_default_op = 0;
2626           int force_scalar = 0;
2627           #ifdef DEBUGGING
2628           int fl=0;
2629           #endif
2630           HV* stash=NULL;
2631            
2632           PERL_ARGS_ASSERT_AMAGIC_CALL;
2633            
2634 20732645 100       if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2635 15278038 100       if (!amagic_is_enabled(method)) return NULL;
2636           }
2637            
2638 16341675 100       if (!(AMGf_noleft & flags) && SvAMAGIC(left)
    100        
    50        
    50        
    50        
    100        
2639 13610245 50       && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
    50        
    100        
    50        
    100        
    50        
    100        
2640 4936956 50       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2641 7405074 50       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2642 9873912         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2643 7405074 50       : NULL))
2644 4936956 100       && ((cv = cvp[off=method+assignshift])
2645 4481314 100       || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
    50        
    100        
2646           * usual method */
2647           (
2648           #ifdef DEBUGGING
2649           fl = 1,
2650           #endif
2651 44         cv = cvp[off=method])))) {
2652           lr = -1; /* Call method for left argument */
2653           } else {
2654 4998959 100       if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
    50        
    100        
2655           int logic;
2656            
2657           /* look for substituted methods */
2658           /* In all the covered cases we should be called with assign==0. */
2659 4362597 100       switch (method) {
    50        
    100        
    100        
2660           case inc_amg:
2661           force_cpy = 1;
2662 22 50       if ((cv = cvp[off=add_ass_amg])
2663 0 0       || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2664           right = &PL_sv_yes; lr = -1; assign = 1;
2665           }
2666           break;
2667           case dec_amg:
2668           force_cpy = 1;
2669 24 50       if ((cv = cvp[off = subtr_ass_amg])
2670 0 0       || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2671           right = &PL_sv_yes; lr = -1; assign = 1;
2672           }
2673           break;
2674           case bool__amg:
2675 2677         (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2676           break;
2677           case numer_amg:
2678 13         (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2679           break;
2680           case string_amg:
2681 564         (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2682           break;
2683           case not_amg:
2684 42         (void)((cv = cvp[off=bool__amg])
2685 28 100       || (cv = cvp[off=numer_amg])
2686 18         || (cv = cvp[off=string_amg]));
2687 42 50       if (cv)
2688           postpr = 1;
2689           break;
2690           case copy_amg:
2691           {
2692           /*
2693           * SV* ref causes confusion with the interpreter variable of
2694           * the same name
2695           */
2696 2         SV* const tmpRef=SvRV(left);
2697 2 50       if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
    50        
2698           /*
2699           * Just to be extra cautious. Maybe in some
2700           * additional cases sv_setsv is safe, too.
2701           */
2702 2         SV* const newref = newSVsv(tmpRef);
2703 2         SvOBJECT_on(newref);
2704           /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
2705           delegate to the stash. */
2706 4         SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2707 2         return newref;
2708           }
2709           }
2710           break;
2711           case abs_amg:
2712 8 50       if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
    50        
2713 0 0       && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
    0        
2714 0         SV* const nullsv=sv_2mortal(newSViv(0));
2715 0 0       if (off1==lt_amg) {
2716 0         SV* const lessp = amagic_call(left,nullsv,
2717           lt_amg,AMGf_noright);
2718 0 0       logic = SvTRUE(lessp);
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
2719           } else {
2720 0         SV* const lessp = amagic_call(left,nullsv,
2721           ncmp_amg,AMGf_noright);
2722 0 0       logic = (SvNV(lessp) < 0);
2723           }
2724 0 0       if (logic) {
2725 0 0       if (off==subtr_amg) {
2726           right = left;
2727           left = nullsv;
2728           lr = 1;
2729           }
2730           } else {
2731           return left;
2732           }
2733           }
2734           break;
2735           case neg_amg:
2736 8 50       if ((cv = cvp[off=subtr_amg])) {
2737           right = left;
2738 0         left = sv_2mortal(newSViv(0));
2739           lr = 1;
2740           }
2741           break;
2742           case int_amg:
2743           case iter_amg: /* XXXX Eventually should do to_gv. */
2744           case ftest_amg: /* XXXX Eventually should do to_gv. */
2745           case regexp_amg:
2746           /* FAIL safe */
2747           return NULL; /* Delegate operation to standard mechanisms. */
2748           break;
2749           case to_sv_amg:
2750           case to_av_amg:
2751           case to_hv_amg:
2752           case to_gv_amg:
2753           case to_cv_amg:
2754           /* FAIL safe */
2755 4358778         return left; /* Delegate operation to standard mechanisms. */
2756           break;
2757           default:
2758           goto not_found;
2759           }
2760 2316 100       if (!cv) goto not_found;
2761 669045 100       } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
    100        
    100        
    100        
    50        
    50        
2762 39445 50       && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
    50        
    0        
    50        
    50        
    50        
    100        
2763 15764 50       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2764 23646 50       && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2765 31528         ? (amtp = (AMT*)mg->mg_ptr)->table
2766 23646 50       : NULL))
2767 15764 100       && (cv = cvp[off=method])) { /* Method for right
2768           * argument found */
2769           lr=1;
2770 635267 100       } else if (((cvp && amtp->fallback > AMGfallNEVER)
    50        
2771 506579 50       || (ocvp && oamtp->fallback > AMGfallNEVER))
    0        
2772 128688 50       && !(flags & AMGf_unary)) {
2773           /* We look for substitution for
2774           * comparison operations and
2775           * concatenation */
2776 192852 100       if (method==concat_amg || method==concat_ass_amg
2777 187076 50       || method==repeat_amg || method==repeat_ass_amg) {
2778           return NULL; /* Delegate operation to string conversion */
2779           }
2780           off = -1;
2781 122912 100       switch (method) {
2782           case lt_amg:
2783           case le_amg:
2784           case gt_amg:
2785           case ge_amg:
2786           case eq_amg:
2787           case ne_amg:
2788           off = ncmp_amg;
2789           break;
2790           case slt_amg:
2791           case sle_amg:
2792           case sgt_amg:
2793           case sge_amg:
2794           case seq_amg:
2795           case sne_amg:
2796           off = scmp_amg;
2797           break;
2798           }
2799 122912 100       if (off != -1) {
2800 120680 100       if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
    50        
2801 117648         cv = ocvp[off];
2802           lr = -1;
2803           }
2804 120680 100       if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
    50        
    50        
2805 4362         cv = cvp[off];
2806           lr = 1;
2807           }
2808           }
2809 122912 100       if (cv)
2810           postpr = 1;
2811           else
2812           goto not_found;
2813           } else {
2814           not_found: /* No method found, either report or croak */
2815 510527 100       switch (method) {
2816           case to_sv_amg:
2817           case to_av_amg:
2818           case to_hv_amg:
2819           case to_gv_amg:
2820           case to_cv_amg:
2821           /* FAIL safe */
2822           return left; /* Delegate operation to standard mechanisms. */
2823           break;
2824           }
2825 119298 100       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
    100        
2826           notfound = 1; lr = -1;
2827 119294 100       } else if (cvp && (cv=cvp[nomethod_amg])) {
    100        
2828           notfound = 1; lr = 1;
2829 238584 100       } else if ((use_default_op =
    100        
2830 3540 100       (!ocvp || oamtp->fallback >= AMGfallYES)
2831 119286 100       && (!cvp || amtp->fallback >= AMGfallYES))
    50        
2832           && !DEBUG_o_TEST) {
2833           /* Skip generating the "no method found" message. */
2834           return NULL;
2835           } else {
2836           SV *msg;
2837           if (off==-1) off=method;
2838 12 50       msg = sv_2mortal(Perl_newSVpvf(aTHX_
    0        
    0        
    0        
    0        
    0        
    50        
    0        
    0        
    50        
    50        
    50        
    50        
    50        
    50        
    50        
    50        
    50        
    50        
    50        
2839           "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
2840           AMG_id2name(method + assignshift),
2841           (flags & AMGf_unary ? " " : "\n\tleft "),
2842           SvAMAGIC(left)?
2843           "in overloaded package ":
2844           "has no overloaded magic",
2845           SvAMAGIC(left)?
2846           SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
2847           SVfARG(&PL_sv_no),
2848           SvAMAGIC(right)?
2849           ",\n\tright argument in overloaded package ":
2850           (flags & AMGf_unary
2851           ? ""
2852           : ",\n\tright argument has no overloaded magic"),
2853           SvAMAGIC(right)?
2854           SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
2855           SVfARG(&PL_sv_no)));
2856 12 50       if (use_default_op) {
2857           DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
2858           } else {
2859 12         Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2860           }
2861           return NULL;
2862           }
2863 6         force_cpy = force_cpy || assign;
2864           }
2865           }
2866            
2867 579186         switch (method) {
2868           /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
2869           * operation. we need this to return a value, so that it can be assigned
2870           * later on, in the postpr block (case inc_amg/dec_amg), even if the
2871           * increment or decrement was itself called in void context */
2872           case inc_amg:
2873 206 50       if (off == add_amg)
2874           force_scalar = 1;
2875           break;
2876           case dec_amg:
2877 256 50       if (off == subtr_amg)
2878           force_scalar = 1;
2879           break;
2880           /* in these cases, we're calling an assignment variant of an operator
2881           * (+= rather than +, for instance). regardless of whether it's a
2882           * fallback or not, it always has to return a value, which will be
2883           * assigned to the proper variable later */
2884           case add_amg:
2885           case subtr_amg:
2886           case mult_amg:
2887           case div_amg:
2888           case modulo_amg:
2889           case pow_amg:
2890           case lshift_amg:
2891           case rshift_amg:
2892           case repeat_amg:
2893           case concat_amg:
2894           case band_amg:
2895           case bor_amg:
2896           case bxor_amg:
2897 39908 100       if (assign)
2898           force_scalar = 1;
2899           break;
2900           /* the copy constructor always needs to return a value */
2901           case copy_amg:
2902           force_scalar = 1;
2903 366         break;
2904           /* because of the way these are implemented (they don't perform the
2905           * dereferencing themselves, they return a reference that perl then
2906           * dereferences later), they always have to be in scalar context */
2907           case to_sv_amg:
2908           case to_av_amg:
2909           case to_hv_amg:
2910           case to_gv_amg:
2911           case to_cv_amg:
2912           force_scalar = 1;
2913 608         break;
2914           /* these don't have an op of their own; they're triggered by their parent
2915           * op, so the context there isn't meaningful ('$a and foo()' in void
2916           * context still needs to pass scalar context on to $a's bool overload) */
2917           case bool__amg:
2918           case numer_amg:
2919           case string_amg:
2920           force_scalar = 1;
2921 94316         break;
2922           }
2923            
2924           #ifdef DEBUGGING
2925           if (!notfound) {
2926           DEBUG_o(Perl_deb(aTHX_
2927           "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
2928           AMG_id2name(off),
2929           method+assignshift==off? "" :
2930           " (initially \"",
2931           method+assignshift==off? "" :
2932           AMG_id2name(method+assignshift),
2933           method+assignshift==off? "" : "\")",
2934           flags & AMGf_unary? "" :
2935           lr==1 ? " for right argument": " for left argument",
2936           flags & AMGf_unary? " for argument" : "",
2937           stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
2938           fl? ",\n\tassignment variant used": "") );
2939           }
2940           #endif
2941           /* Since we use shallow copy during assignment, we need
2942           * to dublicate the contents, probably calling user-supplied
2943           * version of copy operator
2944           */
2945           /* We need to copy in following cases:
2946           * a) Assignment form was called.
2947           * assignshift==1, assign==T, method + 1 == off
2948           * b) Increment or decrement, called directly.
2949           * assignshift==0, assign==0, method + 0 == off
2950           * c) Increment or decrement, translated to assignment add/subtr.
2951           * assignshift==0, assign==T,
2952           * force_cpy == T
2953           * d) Increment or decrement, translated to nomethod.
2954           * assignshift==0, assign==0,
2955           * force_cpy == T
2956           * e) Assignment form translated to nomethod.
2957           * assignshift==1, assign==T, method + 1 != off
2958           * force_cpy == T
2959           */
2960           /* off is method, method+assignshift, or a result of opcode substitution.
2961           * In the latter case assignshift==0, so only notfound case is important.
2962           */
2963 579186 100       if ( (lr == -1) && ( ( (method + assignshift == off)
    100        
2964 455664 100       && (assign || (method == inc_amg) || (method == dec_amg)))
    100        
2965 555478 100       || force_cpy) )
2966           {
2967           /* newSVsv does not behave as advertised, so we copy missing
2968           * information by hand */
2969 16612         SV *tmpRef = SvRV(left);
2970           SV *rv_copy;
2971 16612 100       if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
    50        
2972 368         SvRV_set(left, rv_copy);
2973 368 50       SvSETMAGIC(left);
2974 368         SvREFCNT_dec_NN(tmpRef);
2975           }
2976           }
2977            
2978 579186 50       {
2979 579186         dSP;
2980           BINOP myop;
2981           SV* res;
2982 579186         const bool oldcatch = CATCH_GET;
2983           I32 oldmark, nret;
2984 579186 100       int gimme = force_scalar ? G_SCALAR : GIMME_V;
    50        
2985            
2986 579186         CATCH_SET(TRUE);
2987           Zero(&myop, 1, BINOP);
2988 579186         myop.op_last = (OP *) &myop;
2989 579186         myop.op_next = NULL;
2990 579186         myop.op_flags = OPf_STACKED;
2991            
2992 579186         switch (gimme) {
2993           case G_VOID:
2994 212         myop.op_flags |= OPf_WANT_VOID;
2995 212         break;
2996           case G_ARRAY:
2997 26 50       if (flags & AMGf_want_list) {
2998 0         myop.op_flags |= OPf_WANT_LIST;
2999 0         break;
3000           }
3001           /* FALLTHROUGH */
3002           default:
3003 578974         myop.op_flags |= OPf_WANT_SCALAR;
3004 578974         break;
3005           }
3006            
3007 579186 100       PUSHSTACKi(PERLSI_OVERLOAD);
3008 579186         ENTER;
3009 579186         SAVEOP();
3010 579186         PL_op = (OP *) &myop;
3011 579186 100       if (PERLDB_SUB && PL_curstash != PL_debstash)
    100        
    100        
3012 4         PL_op->op_private |= OPpENTERSUB_DB;
3013 579186         PUTBACK;
3014 579186         Perl_pp_pushmark(aTHX);
3015            
3016 289233         EXTEND(SP, notfound + 5);
3017 579186 100       PUSHs(lr>0? right: left);
3018 579186 100       PUSHs(lr>0? left: right);
3019 579186 100       PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
    100        
3020 579186 100       if (notfound) {
3021 6         PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3022           AMG_id2namelen(method + assignshift), SVs_TEMP));
3023           }
3024 579186         PUSHs(MUTABLE_SV(cv));
3025 579186         PUTBACK;
3026 579186         oldmark = TOPMARK;
3027            
3028 579186 100       if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3029 439340         CALLRUNOPS(aTHX);
3030 578970         LEAVE;
3031 578970         SPAGAIN;
3032 578970         nret = SP - (PL_stack_base + oldmark);
3033            
3034 578970         switch (gimme) {
3035           case G_VOID:
3036           /* returning NULL has another meaning, and we check the context
3037           * at the call site too, so this can be differentiated from the
3038           * scalar case */
3039           res = &PL_sv_undef;
3040 212         SP = PL_stack_base + oldmark;
3041 212         break;
3042           case G_ARRAY: {
3043 26 50       if (flags & AMGf_want_list) {
3044 0         res = sv_2mortal((SV *)newAV());
3045 0         av_extend((AV *)res, nret);
3046 0 0       while (nret--)
3047 0         av_store((AV *)res, nret, POPs);
3048           break;
3049           }
3050           /* FALLTHROUGH */
3051           }
3052           default:
3053 578758         res = POPs;
3054 578758         break;
3055           }
3056            
3057 578970         PUTBACK;
3058 578970 50       POPSTACK;
3059 578970         CATCH_SET(oldcatch);
3060            
3061 578970 100       if (postpr) {
3062           int ans;
3063 119368         switch (method) {
3064           case le_amg:
3065           case sle_amg:
3066 160 50       ans=SvIV(res)<=0; break;
3067           case lt_amg:
3068           case slt_amg:
3069 49494 50       ans=SvIV(res)<0; break;
3070           case ge_amg:
3071           case sge_amg:
3072 28032 50       ans=SvIV(res)>=0; break;
3073           case gt_amg:
3074           case sgt_amg:
3075 3220 50       ans=SvIV(res)>0; break;
3076           case eq_amg:
3077           case seq_amg:
3078 38006 50       ans=SvIV(res)==0; break;
3079           case ne_amg:
3080           case sne_amg:
3081 414 50       ans=SvIV(res)!=0; break;
3082           case inc_amg:
3083           case dec_amg:
3084 0 0       SvSetSV(left,res); return left;
3085           case not_amg:
3086 42 50       ans=!SvTRUE(res); break;
    50        
    0        
    100        
    50        
    50        
    100        
    50        
    50        
    0        
    0        
    50        
    50        
    50        
    100        
    50        
    0        
    100        
    0        
3087           default:
3088           ans=0; break;
3089           }
3090 119368 100       return boolSV(ans);
3091 459602 100       } else if (method==copy_amg) {
3092 366 50       if (!SvROK(res)) {
3093 0         Perl_croak(aTHX_ "Copy method did not return a reference");
3094           }
3095 366         return SvREFCNT_inc(SvRV(res));
3096           } else {
3097           return res;
3098           }
3099           }
3100           }
3101            
3102           void
3103 63309958         Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3104           {
3105           dVAR;
3106           U32 hash;
3107            
3108           PERL_ARGS_ASSERT_GV_NAME_SET;
3109            
3110 63309958 50       if (len > I32_MAX)
3111 0         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
3112            
3113 63309958 50       if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
    0        
3114 0         unshare_hek(GvNAME_HEK(gv));
3115           }
3116            
3117 63309958         PERL_HASH(hash, name, len);
3118 63309958 100       GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3119 63309958         }
3120            
3121           /*
3122           =for apidoc gv_try_downgrade
3123            
3124           If the typeglob C can be expressed more succinctly, by having
3125           something other than a real GV in its place in the stash, replace it
3126           with the optimised form. Basic requirements for this are that C
3127           is a real typeglob, is sufficiently ordinary, and is only referenced
3128           from its package. This function is meant to be used when a GV has been
3129           looked up in part to see what was there, causing upgrading, but based
3130           on what was found it turns out that the real GV isn't required after all.
3131            
3132           If C is a completely empty typeglob, it is deleted from the stash.
3133            
3134           If C is a typeglob containing only a sufficiently-ordinary constant
3135           sub, the typeglob is replaced with a scalar-reference placeholder that
3136           more compactly represents the same thing.
3137            
3138           =cut
3139           */
3140            
3141           void
3142 8451555         Perl_gv_try_downgrade(pTHX_ GV *gv)
3143           {
3144           HV *stash;
3145           CV *cv;
3146           HEK *namehek;
3147           SV **gvp;
3148           PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3149            
3150           /* XXX Why and where does this leave dangling pointers during global
3151           destruction? */
3152 8451555 50       if (PL_phase == PERL_PHASE_DESTRUCT) return;
3153            
3154 15108260 100       if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
    100        
3155 12496750 50       !SvOBJECT(gv) && !SvREADONLY(gv) &&
3156 16541945 50       isGV_with_GP(gv) && GvGP(gv) &&
    50        
    100        
3157 16486596 100       !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
    100        
3158 18073345 100       !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
    100        
    100        
    100        
    100        
3159 9839138 50       GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
    50        
3160           return;
3161 6656597 100       if (SvMAGICAL(gv)) {
3162           MAGIC *mg;
3163           /* only backref magic is allowed */
3164 3561430 50       if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3165           return;
3166 7122860 100       for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3167 3561430 50       if (mg->mg_type != PERL_MAGIC_backref)
3168           return;
3169           }
3170           }
3171 6656597         cv = GvCV(gv);
3172 6656597 100       if (!cv) {
3173 2233647         HEK *gvnhek = GvNAME_HEK(gv);
3174 2233647 100       (void)hv_delete(stash, HEK_KEY(gvnhek),
3175           HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
3176 4422950 50       } else if (GvMULTI(gv) && cv &&
3177 6520070 100       !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
    100        
3178 6130891 100       CvSTASH(cv) == stash && CvGV(cv) == gv &&
    100        
3179 3377860 50       CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
    50        
    50        
    50        
3180 2772398 50       !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
    50        
    50        
    50        
3181 2096938 50       (namehek = GvNAME_HEK(gv)) &&
3182 1421478 100       (gvp = hv_fetch(stash, HEK_KEY(namehek),
3183 1421478 50       HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
3184 1421478         *gvp == (SV*)gv) {
3185 1421478         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3186 1421478         const bool imported = !!GvIMPORTED_CV(gv);
3187 1421478         SvREFCNT(gv) = 0;
3188 1421478         sv_clear((SV*)gv);
3189 1421478         SvREFCNT(gv) = 1;
3190 1421478         SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
3191 1421478         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3192           STRUCT_OFFSET(XPVIV, xiv_iv));
3193 5081754         SvRV_set(gv, value);
3194           }
3195           }
3196            
3197           #include "XSUB.h"
3198            
3199           static void
3200 44         core_xsub(pTHX_ CV* cv)
3201           {
3202 44         Perl_croak(aTHX_
3203 44         "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3204           );
3205 63694458         }
3206            
3207           /*
3208           * Local variables:
3209           * c-indentation-style: bsd
3210           * c-basic-offset: 4
3211           * indent-tabs-mode: nil
3212           * End:
3213           *
3214           * ex: set ts=8 sts=4 sw=4 et:
3215           */