File Coverage

hax/cv_copy_flags.c.inc
Criterion Covered Total %
statement 44 51 86.2
branch 33 42 78.5
condition n/a
subroutine n/a
pod n/a
total 77 93 82.8


line stmt bran cond sub pod time code
1             /* vi: set ft=c : */
2              
3             #define padname_is_normal_lexical(pname) MY_padname_is_normal_lexical(aTHX_ pname)
4             static bool MY_padname_is_normal_lexical(pTHX_ PADNAME *pname)
5             {
6             /* PAD slots without names are certainly not lexicals */
7 605 50         if(PadnameIsNULL(pname) || !PadnameLEN(pname))
    100          
    50          
    100          
8             return FALSE;
9              
10             /* Outer lexical captures are not lexicals */
11 371 100         if(PadnameOUTER(pname))
    100          
12             return FALSE;
13              
14             /* state variables are not lexicals */
15 220 100         if(PadnameIsSTATE(pname))
    100          
16             return FALSE;
17              
18             /* Protosubs for closures are not lexicals */
19 184 100         if(PadnamePV(pname)[0] == '&')
    100          
20             return FALSE;
21              
22             /* anything left is a normal lexical */
23             return TRUE;
24             }
25              
26             enum {
27             CV_COPY_NULL_LEXICALS = (1<<0), /* regular lexicals end up NULL */
28             };
29              
30             #define cv_copy_flags(orig, flags) MY_cv_copy_flags(aTHX_ orig, flags)
31 94           static CV *MY_cv_copy_flags(pTHX_ CV *orig, U32 flags)
32             {
33             /* Parts of this code stolen from S_cv_clone() in pad.c
34             */
35 94           CV *new = MUTABLE_CV(newSV_type(SVt_PVCV));
36 94           CvFLAGS(new) = CvFLAGS(orig) & ~CVf_CVGV_RC;
37              
38 94 50         CvFILE(new) = CvDYNFILE(orig) ? savepv(CvFILE(orig)) : CvFILE(orig);
39             #if HAVE_PERL_VERSION(5, 18, 0)
40 94 50         if(CvNAMED(orig)) {
41             /* Perl core uses CvNAME_HEK_set() here, but that involves a call to a
42             * non-public function unshare_hek(). The latter is only needed in the
43             * case where an old value needs to be removed, but since we've only just
44             * created the CV we know it will be empty, so we can just set the field
45             * directly
46             */
47 0           ((XPVCV*)MUTABLE_PTR(SvANY(new)))->xcv_gv_u.xcv_hek = share_hek_hek(CvNAME_HEK(orig));
48 0           CvNAMED_on(new);
49             }
50             else
51             #endif
52 94           CvGV_set(new, CvGV(orig));
53              
54 94           CvSTASH_set(new, CvSTASH(orig));
55             {
56             OP_REFCNT_LOCK;
57 94 50         CvROOT(new) = OpREFCNT_inc(CvROOT(orig));
58             OP_REFCNT_UNLOCK;
59             }
60 94           CvSTART(new) = CvSTART(orig);
61 188           CvOUTSIDE(new) = MUTABLE_CV(SvREFCNT_inc(CvOUTSIDE(orig)));
62 94           CvOUTSIDE_SEQ(new) = CvOUTSIDE_SEQ(orig);
63              
64             /* No need to bother with SvPV slot because that's the prototype, and it's
65             * too late for that here
66             */
67             /* TODO: Consider what to do about SvPVX */
68              
69             {
70 94           ENTER_with_name("cv_copy_flags");
71              
72 94           SAVESPTR(PL_compcv);
73 94           PL_compcv = new;
74              
75 94           SAVESPTR(PL_comppad_name);
76 94           PL_comppad_name = PadlistNAMES(CvPADLIST(orig));
77 94           CvPADLIST_set(new, pad_new(padnew_CLONE|padnew_SAVE));
78             #if HAVE_PERL_VERSION(5, 22, 0)
79 94           CvPADLIST(new)->xpadl_id = CvPADLIST(orig)->xpadl_id;
80             #endif
81              
82 94           PADNAMELIST *padnames = PadlistNAMES(CvPADLIST(orig));
83 94           const PADOFFSET fnames = PadnamelistMAX(padnames);
84 94           const PADOFFSET fpad = AvFILLp(PadlistARRAY(CvPADLIST(orig))[1]);
85 94           int depth = CvDEPTH(orig);
86 94 50         if(!depth)
87             depth = 1;
88 94           SV **origpad = AvARRAY(PadlistARRAY(CvPADLIST(orig))[depth]);
89              
90             #if !HAVE_PERL_VERSION(5, 18, 0)
91             /* Perls before 5.18.0 didn't copy the padnameslist
92             */
93             SvREFCNT_dec(PadlistNAMES(CvPADLIST(new)));
94             PadlistNAMES(CvPADLIST(new)) = (PADNAMELIST *)SvREFCNT_inc(PadlistNAMES(CvPADLIST(orig)));
95             #endif
96              
97 94           av_fill(PL_comppad, fpad);
98 94           PL_curpad = AvARRAY(PL_comppad);
99              
100 94           PADNAME **pnames = PadnamelistARRAY(padnames);
101             PADOFFSET padix;
102              
103             /* TODO: What about padix 0? */
104              
105 358 100         for(padix = 1; padix <= fpad; padix++) {
106 264 50         PADNAME *pname = (padix <= fnames) ? pnames[padix] : NULL;
107             SV *newval = NULL;
108              
109 264 100         if(padname_is_normal_lexical(pname)) {
110 78 50         if(flags & CV_COPY_NULL_LEXICALS)
111 78           continue;
112              
113 0           switch(PadnamePV(pname)[0]) {
114 0           case '$': newval = newSV(0); break;
115 0           case '@': newval = MUTABLE_SV(newAV()); break;
116 0           case '%': newval = MUTABLE_SV(newHV()); break;
117             default:
118 0           croak("ARGH unsure how to handle pname=<%s> in cv_copy_flags\n",
119             PadnamePV(pname));
120             break;
121             }
122             }
123 186 100         else if(!origpad[padix])
124             newval = NULL;
125 181 100         else if(SvPADTMP(origpad[padix])) {
126             /* We still have to copy the value, in case it is live. Also core perl
127             * is known to set SvPADTMP on non-temporaries, like folded constants
128             * https://rt.cpan.org/Ticket/Display.html?id=142468
129             */
130 92           newval = newSVsv(origpad[padix]);
131 92           SvPADTMP_on(newval);
132             }
133             else {
134             #if !HAVE_PERL_VERSION(5, 18, 0)
135             /* Before perl 5.18.0, inner anon subs didn't find the right CvOUTSIDE
136             * at runtime, so we'll have to patch them up here
137             */
138             CV *origproto;
139             if(pname && PadnamePV(pname)[0] == '&' &&
140             CvOUTSIDE(origproto = MUTABLE_CV(origpad[padix])) == orig) {
141             /* quiet any "Variable $FOO is not available" warnings about lexicals
142             * yet to be introduced
143             */
144             ENTER_with_name("find_cv_outside");
145             SAVEINT(CvDEPTH(origproto));
146             CvDEPTH(origproto) = 1;
147              
148             CV *newproto = cv_copy_flags(origproto, flags);
149             CvPADLIST_set(newproto, CvPADLIST(origproto));
150             CvSTART(newproto) = CvSTART(origproto);
151              
152             SvREFCNT_dec(CvOUTSIDE(newproto));
153             CvOUTSIDE(newproto) = MUTABLE_CV(SvREFCNT_inc_simple_NN(new));
154              
155             LEAVE_with_name("find_cv_outside");
156              
157             newval = MUTABLE_SV(newproto);
158             }
159             else
160             #endif
161 89 50         if(origpad[padix])
162             newval = SvREFCNT_inc_NN(origpad[padix]);
163             }
164              
165 186           PL_curpad[padix] = newval;
166             }
167              
168 94           LEAVE_with_name("cv_copy_flags");
169             }
170              
171 94           return new;
172             }