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