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
|
/* 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(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
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]);
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(origpad[padix])
newval = SvREFCNT_inc_NN(origpad[padix]);
}
PL_curpad[padix] = newval;
}
LEAVE_with_name("cv_copy_flags");
}
return new;
}
|
