1 #define PERL_NO_GET_CONTEXT 1
2 #include "EXTERN.h"
3 #include "perl.h"
4 #include "XSUB.h"
5
6 #define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
7 #define PERL_DECIMAL_VERSION \
8 PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
9 #define PERL_VERSION_GE(r,v,s) \
10 (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
11
12 #if !PERL_VERSION_GE(5,9,3)
13 # define SVt_LAST (SVt_PVIO+1)
14 #endif /* <5.9.3 */
15
16 #if PERL_VERSION_GE(5,9,4)
17 # define SVt_PADNAME SVt_PVMG
18 #else /* <5.9.4 */
19 # define SVt_PADNAME SVt_PVGV
20 #endif /* <5.9.4 */
21
22 #ifndef sv_setpvs
23 # define sv_setpvs(SV, STR) sv_setpvn(SV, ""STR"", sizeof(STR)-1)
24 #endif /* !sv_setpvs */
25
26 #ifndef gv_stashpvs
27 # define gv_stashpvs(name, flags) gv_stashpvn(""name"", sizeof(name)-1, flags)
28 #endif /* !gv_stashpvs */
29
30 #ifndef SvPAD_OUR_on
31 # define SvPAD_OUR_on(SV) (SvFLAGS(SV) |= SVpad_OUR)
32 #endif /* !SvPAD_OUR_on */
33
34 #ifndef SvOURSTASH_set
35 # ifdef OURSTASH_set
36 # define SvOURSTASH_set(SV, STASH) OURSTASH_set(SV, STASH)
37 # else /* !OURSTASH_set */
38 # define SvOURSTASH_set(SV, STASH) (GvSTASH(SV) = STASH)
39 # endif /* !OURSTASH_set */
40 #endif /* !SvOURSTASH_set */
41
42 #ifndef PadMAX
43 # define PadlistARRAY(pl) ((PAD**)AvARRAY(pl))
44 # define PadlistNAMES(pl) (PadlistARRAY(pl)[0])
45 # define PadMAX(p) AvFILLp(p)
46 typedef AV PADNAMELIST;
47 #endif /* !PadMAX */
48
49 #if !PERL_VERSION_GE(5,8,1)
50 typedef AV PADLIST;
51 typedef AV PAD;
52 #endif /* <5.8.1 */
53
54 #ifndef COP_SEQ_RANGE_LOW
55 # if PERL_VERSION_GE(5,9,5)
56 # define COP_SEQ_RANGE_LOW(sv) ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow
57 # define COP_SEQ_RANGE_HIGH(sv) ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh
58 # else /* <5.9.5 */
59 # define COP_SEQ_RANGE_LOW(sv) ((U32)SvNVX(sv))
60 # define COP_SEQ_RANGE_HIGH(sv) ((U32)SvIVX(sv))
61 # endif /* <5.9.5 */
62 #endif /* !COP_SEQ_RANGE_LOW */
63
64 #ifndef COP_SEQ_RANGE_LOW_set
65 # ifdef newPADNAMEpvn
66 # define COP_SEQ_RANGE_LOW_set(sv,val) \
67 do { (sv)->xpadn_low = (val); } while(0)
68 # define COP_SEQ_RANGE_HIGH_set(sv,val) \
69 do { (sv)->xpadn_high = (val); } while(0)
70 # elif PERL_VERSION_GE(5,9,5)
71 # define COP_SEQ_RANGE_LOW_set(sv,val) \
72 do { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = val; } while(0)
73 # define COP_SEQ_RANGE_HIGH_set(sv,val) \
74 do { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = val; } while(0)
75 # else /* <5.9.5 */
76 # define COP_SEQ_RANGE_LOW_set(sv,val) SvNV_set(sv, val)
77 # define COP_SEQ_RANGE_HIGH_set(sv,val) SvIV_set(sv, val)
78 # endif /* <5.9.5 */
79 #endif /* !COP_SEQ_RANGE_LOW_set */
80
81 #ifndef SvRV_set
82 # define SvRV_set(SV, VAL) (SvRV(SV) = (VAL))
83 #endif /* !SvRV_set */
84
85 #ifndef newSV_type
86 # define newSV_type(type) THX_newSV_type(aTHX_ type)
THX_newSV_type(pTHX_ svtype type)87 static SV *THX_newSV_type(pTHX_ svtype type)
88 {
89 SV *sv = newSV(0);
90 (void) SvUPGRADE(sv, type);
91 return sv;
92 }
93 #endif /* !newSV_type */
94
95 #ifndef SVfARG
96 # define SVfARG(p) ((void *)p)
97 #endif /* !SVfARG */
98
99 #ifndef GV_NOTQUAL
100 # define GV_NOTQUAL 0
101 #endif /* !GV_NOTQUAL */
102
103 #ifndef padnamelist_store
104 /* Note that the return values are different. If we ever call it in non-
105 void context, we would have to change it to *av_store. */
106 # define padnamelist_store av_store
107 #endif
108
109 /*
110 * scalar classification
111 *
112 * Logic borrowed from Params::Classify.
113 */
114
115 #define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
116
117 #if PERL_VERSION_GE(5,11,0)
118 # define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP)
119 #else /* <5.11.0 */
120 # define sv_is_regexp(sv) 0
121 #endif /* <5.11.0 */
122
123 #define sv_is_string(sv) \
124 (!sv_is_glob(sv) && !sv_is_regexp(sv) && \
125 (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)))
126
127 /*
128 * gen_const_identity_op()
129 *
130 * This function generate op that evaluates to a fixed object identity
131 * and can also participate in constant folding.
132 *
133 * Lexical::Var generally needs to make ops that evaluate to fixed
134 * identities, that being what a name that it handles represents.
135 * Normally it can do this by means of an rv2xv op applied to a const op,
136 * where the const op holds an RV that references the object of interest.
137 * However, rv2xv can't undergo constant folding. Where the object is
138 * a readonly scalar, we'd like it to take part in constant folding.
139 * The obvious way to make it work as a constant for folding is to use a
140 * const op that directly holds the object. However, in a Perl built for
141 * ithreads, the value in a const op gets moved into the pad to achieve
142 * clonability, and in the process the value may be copied rather than the
143 * object merely rereferenced. Generally, the const op only guarantees
144 * to provide a fixed *value*, not a fixed object identity.
145 *
146 * Where a const op might not preserve object identity, we can achieve
147 * preservation by means of a customised variant of the const op. The op
148 * directly holds an RV that references the object of interest, and its
149 * variant pp function dereferences it (as rv2sv would). The pad logic
150 * operates on the op structure as normal, and may copy the RV without
151 * preserving its identity, which is OK because the RV isn't what we
152 * need to preserve. Being labelled as a const op, it is eligible for
153 * constant folding. When actually executed, it evaluates to the object
154 * of interest, providing both fixed value and fixed identity.
155 */
156
157 #ifdef USE_ITHREADS
158 # define Q_USE_ITHREADS 1
159 #else /* !USE_ITHREADS */
160 # define Q_USE_ITHREADS 0
161 #endif /* !USE_ITHREADS */
162
163 #define Q_CONST_COPIES Q_USE_ITHREADS
164
165 #if Q_CONST_COPIES
pp_const_via_ref(pTHX)166 static OP *pp_const_via_ref(pTHX)
167 {
168 dSP;
169 SV *reference_sv = cSVOPx_sv(PL_op);
170 SV *referent_sv = SvRV(reference_sv);
171 PUSHs(referent_sv);
172 RETURN;
173 }
174 #endif /* Q_CONST_COPIES */
175
176 #define gen_const_identity_op(sv) THX_gen_const_identity_op(aTHX_ sv)
THX_gen_const_identity_op(pTHX_ SV * sv)177 static OP *THX_gen_const_identity_op(pTHX_ SV *sv)
178 {
179 #if Q_CONST_COPIES
180 OP *op = newSVOP(OP_CONST, 0, newRV_noinc(sv));
181 op->op_ppaddr = pp_const_via_ref;
182 return op;
183 #else /* !Q_CONST_COPIES */
184 return newSVOP(OP_CONST, 0, sv);
185 #endif /* !Q_CONST_COPIES */
186 }
187
188 /*
189 * %^H key names
190 */
191
192 #define KEYPREFIX "Lexical::Var/"
193 #define KEYPREFIXLEN (sizeof(KEYPREFIX)-1)
194
195 #define LEXPADPREFIX "Lexical::Var::<LEX>"
196 #define LEXPADPREFIXLEN (sizeof(LEXPADPREFIX)-1)
197
198 #define CHAR_IDSTART 0x01
199 #define CHAR_IDCONT 0x02
200 #define CHAR_SIGIL 0x10
201 #define CHAR_USEPAD 0x20
202
203 static U8 char_attr[256] = {
204 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* NUL to BEL */
205 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* BS to SI */
206 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* DLE to ETB */
207 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* CAN to US */
208 0x00, 0x00, 0x00, 0x00, 0x30, 0x30, 0x10, 0x00, /* SP to ' */
209 0x00, 0x00, 0x10, 0x00, 0x00, 0x00, 0x00, 0x00, /* ( to / */
210 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, /* 0 to 7 */
211 0x02, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 8 to ? */
212 0x30, 0x03, 0x03, 0x03, 0x03, 0x03, 0x03, 0x03, /* @ to G */
213 0x03, 0x03, 0x03, 0x03, 0x03, 0x03, 0x03, 0x03, /* H to O */
214 0x03, 0x03, 0x03, 0x03, 0x03, 0x03, 0x03, 0x03, /* P to W */
215 0x03, 0x03, 0x03, 0x00, 0x00, 0x00, 0x00, 0x03, /* X to _ */
216 0x00, 0x03, 0x03, 0x03, 0x03, 0x03, 0x03, 0x03, /* ` to g */
217 0x03, 0x03, 0x03, 0x03, 0x03, 0x03, 0x03, 0x03, /* h to o */
218 0x03, 0x03, 0x03, 0x03, 0x03, 0x03, 0x03, 0x03, /* p to w */
219 0x03, 0x03, 0x03, 0x00, 0x00, 0x00, 0x00, 0x00, /* x to DEL */
220 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0,
221 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0,
222 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0,
223 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0,
224 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0,
225 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0,
226 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0,
227 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0,
228 };
229
230 #define name_key(sigil, name) THX_name_key(aTHX_ sigil, name)
THX_name_key(pTHX_ char sigil,SV * name)231 static SV *THX_name_key(pTHX_ char sigil, SV *name)
232 {
233 char const *p, *q, *end;
234 STRLEN len;
235 SV *key;
236 p = SvPV(name, len);
237 end = p + len;
238 if(sigil == 'N') {
239 sigil = *p++;
240 if(!(char_attr[(U8)sigil] & CHAR_SIGIL)) return NULL;
241 } else if(sigil == 'P') {
242 if(strnNE(p, LEXPADPREFIX, LEXPADPREFIXLEN)) return NULL;
243 p += LEXPADPREFIXLEN;
244 sigil = *p++;
245 if(!(char_attr[(U8)sigil] & CHAR_SIGIL)) return NULL;
246 if(p[0] != ':' || p[1] != ':') return NULL;
247 p += 2;
248 }
249 if(!(char_attr[(U8)*p] & CHAR_IDSTART)) return NULL;
250 for(q = p+1; q != end; q++) {
251 if(!(char_attr[(U8)*q] & CHAR_IDCONT)) return NULL;
252 }
253 key = sv_2mortal(newSV(KEYPREFIXLEN + 1 + (end-p)));
254 sv_setpvs(key, KEYPREFIX"?");
255 SvPVX(key)[KEYPREFIXLEN] = sigil;
256 sv_catpvn(key, p, end-p);
257 return key;
258 }
259
260 /*
261 * compiling code that uses lexical variables
262 */
263
264 #define gv_mark_multi(name) THX_gv_mark_multi(aTHX_ name)
THX_gv_mark_multi(pTHX_ SV * name)265 static void THX_gv_mark_multi(pTHX_ SV *name)
266 {
267 GV *gv;
268 #ifdef gv_fetchsv
269 gv = gv_fetchsv(name, GV_NOADD_NOINIT|GV_NOEXPAND|GV_NOTQUAL,
270 SVt_PVGV);
271 #else /* !gv_fetchsv */
272 gv = gv_fetchpv(SvPVX(name), 0, SVt_PVGV);
273 #endif /* !gv_fetchsv */
274 if(gv && SvTYPE(gv) == SVt_PVGV) GvMULTI_on(gv);
275 }
276
277 static SV *fake_sv, *fake_av, *fake_hv;
278
279 #define ck_rv2xv(o, sigil, nxck) THX_ck_rv2xv(aTHX_ o, sigil, nxck)
THX_ck_rv2xv(pTHX_ OP * o,char sigil,OP * (* nxck)(pTHX_ OP * o))280 static OP *THX_ck_rv2xv(pTHX_ OP *o, char sigil, OP *(*nxck)(pTHX_ OP *o))
281 {
282 OP *c;
283 SV *ref, *key;
284 HE *he;
285 if((o->op_flags & OPf_KIDS) && (c = cUNOPx(o)->op_first) &&
286 c->op_type == OP_CONST &&
287 (c->op_private & (OPpCONST_ENTERED|OPpCONST_BARE)) &&
288 (ref = cSVOPx(c)->op_sv) && SvPOK(ref) &&
289 (key = name_key(sigil, ref))) {
290 if((he = hv_fetch_ent(GvHV(PL_hintgv), key, 0, 0))) {
291 SV *hintref, *referent, *fake_referent, *newref;
292 OP *newop;
293 U16 type, flags;
294 #if !PERL_VERSION_GE(5,11,2)
295 if(sigil == '&' && (c->op_private & OPpCONST_BARE))
296 croak("can't reference lexical subroutine "
297 "without & sigil on this perl");
298 #endif /* <5.11.2 */
299 if(sigil != 'P' || !PERL_VERSION_GE(5,8,0)) {
300 /*
301 * A bogus symbol lookup has already been
302 * done (by the tokeniser) based on the name
303 * we're using, to support the package-based
304 * interpretation that we're about to
305 * replace. This can cause bogus "used only
306 * once" warnings. The best we can do here
307 * is to flag the symbol as multiply-used to
308 * suppress that warning, though this is at
309 * the risk of muffling an accurate warning.
310 */
311 gv_mark_multi(ref);
312 }
313 /*
314 * The base checker for rv2Xv checks that the
315 * item being pointed to by the constant ref is of
316 * an appropriate type. There are two problems with
317 * this check. Firstly, it rejects GVs as a scalar
318 * target, whereas they are in fact valid. (This
319 * is in RT as bug #69456 so may be fixed.) Second,
320 * and more serious, sometimes a reference is being
321 * constructed through the wrong op type. An array
322 * indexing expression "$foo[0]" gets constructed as
323 * an rv2sv op, because of the "$" sigil, and then
324 * gets munged later. We have to detect the real
325 * intended type through the pad entry, which the
326 * tokeniser has worked out in advance, and then
327 * work through the wrong op. So it's a bit cheeky
328 * for perl to complain about the wrong type here.
329 * We work around it by making the constant ref
330 * initially point to an innocuous item to pass the
331 * type check, then changing it to the real
332 * reference later.
333 */
334 hintref = HeVAL(he);
335 if(!SvROK(hintref))
336 croak("non-reference hint for Lexical::Var");
337 referent = SvREFCNT_inc(SvRV(hintref));
338 type = o->op_type;
339 flags = o->op_flags | (((U16)o->op_private) << 8);
340 if(type == OP_RV2SV && sigil == 'P' &&
341 SvPVX(ref)[LEXPADPREFIXLEN] == '$' &&
342 SvREADONLY(referent)) {
343 op_free(o);
344 return gen_const_identity_op(referent);
345 }
346 switch(type) {
347 case OP_RV2SV: fake_referent = fake_sv; break;
348 case OP_RV2AV: fake_referent = fake_av; break;
349 case OP_RV2HV: fake_referent = fake_hv; break;
350 default: fake_referent = referent; break;
351 }
352 newref = newRV_noinc(fake_referent);
353 if(referent != fake_referent) {
354 SvREFCNT_inc(fake_referent);
355 SvREFCNT_inc(newref);
356 }
357 newop = newUNOP(type, flags,
358 newSVOP(OP_CONST, 0, newref));
359 if(referent != fake_referent) {
360 fake_referent = SvRV(newref);
361 SvREADONLY_off(newref);
362 SvRV_set(newref, referent);
363 SvREADONLY_on(newref);
364 SvREFCNT_dec(fake_referent);
365 SvREFCNT_dec(newref);
366 }
367 op_free(o);
368 return newop;
369 } else if(sigil == 'P') {
370 SV *newref;
371 U16 type, flags;
372 /*
373 * Not a name that we have a defined meaning for,
374 * but it has the form of the "our" hack, implying
375 * that we did put an entry in the pad for it.
376 * Munge this back to what it would have been
377 * without the pad entry. This should mainly
378 * happen due to explicit unimportation, but it
379 * might also happen if the scoping of the pad and
380 * %^H ever get out of synch.
381 */
382 newref = newSVpvn(SvPVX(ref)+LEXPADPREFIXLEN+3,
383 SvCUR(ref)-LEXPADPREFIXLEN-3);
384 if(SvUTF8(ref)) SvUTF8_on(newref);
385 type = o->op_type;
386 flags = o->op_flags | (((U16)o->op_private) << 8);
387 op_free(o);
388 return newUNOP(type, flags,
389 newSVOP(OP_CONST, 0, newref));
390 }
391 }
392 return nxck(aTHX_ o);
393 }
394
395 static OP *(*nxck_rv2sv)(pTHX_ OP *o);
396 static OP *(*nxck_rv2av)(pTHX_ OP *o);
397 static OP *(*nxck_rv2hv)(pTHX_ OP *o);
398 static OP *(*nxck_rv2cv)(pTHX_ OP *o);
399 static OP *(*nxck_rv2gv)(pTHX_ OP *o);
400
ck_rv2sv(pTHX_ OP * o)401 static OP *ck_rv2sv(pTHX_ OP *o) { return ck_rv2xv(o, 'P', nxck_rv2sv); }
ck_rv2av(pTHX_ OP * o)402 static OP *ck_rv2av(pTHX_ OP *o) { return ck_rv2xv(o, 'P', nxck_rv2av); }
ck_rv2hv(pTHX_ OP * o)403 static OP *ck_rv2hv(pTHX_ OP *o) { return ck_rv2xv(o, 'P', nxck_rv2hv); }
ck_rv2cv(pTHX_ OP * o)404 static OP *ck_rv2cv(pTHX_ OP *o) { return ck_rv2xv(o, '&', nxck_rv2cv); }
ck_rv2gv(pTHX_ OP * o)405 static OP *ck_rv2gv(pTHX_ OP *o) { return ck_rv2xv(o, '*', nxck_rv2gv); }
406
407 /*
408 * setting up lexical names
409 */
410
411 static HV *stash_lex_sv, *stash_lex_av, *stash_lex_hv;
412
413 #define pad_max() THX_pad_max(aTHX)
THX_pad_max(pTHX)414 static U32 THX_pad_max(pTHX)
415 {
416 #if PERL_VERSION_GE(5,13,10)
417 return U32_MAX;
418 #elif PERL_VERSION_GE(5,9,5)
419 return I32_MAX;
420 #elif PERL_VERSION_GE(5,9,0)
421 return 999999999;
422 #elif PERL_VERSION_GE(5,8,0)
423 static U32 max;
424 if(!max) {
425 SV *versv = get_sv("]", 0);
426 char *verp = SvPV_nolen(versv);
427 max = strGE(verp, "5.008009") ? I32_MAX : 999999999;
428 }
429 return max;
430 #else /* <5.8.0 */
431 return 999999999;
432 #endif /* <5.8.0 */
433 }
434
435 #define find_compcv(vari_word) THX_find_compcv(aTHX_ vari_word)
THX_find_compcv(pTHX_ char const * vari_word)436 static CV *THX_find_compcv(pTHX_ char const *vari_word)
437 {
438 CV *compcv;
439 #if PERL_VERSION_GE(5,17,5)
440 if(!((compcv = PL_compcv) && CvPADLIST(compcv)))
441 compcv = NULL;
442 #else /* <5.17.5 */
443 GV *compgv;
444 /*
445 * Given that we're being invoked from a BEGIN block,
446 * PL_compcv here doesn't actually point to the sub
447 * being compiled. Instead it points to the BEGIN block.
448 * The code that we want to affect is the parent of that.
449 * Along the way, better check that we are actually being
450 * invoked that way: PL_compcv may be null, indicating
451 * runtime, or it can be non-null in a couple of
452 * other situations (require, string eval).
453 */
454 if(!(PL_compcv && CvSPECIAL(PL_compcv) &&
455 (compgv = CvGV(PL_compcv)) &&
456 strEQ(GvNAME(compgv), "BEGIN") &&
457 (compcv = CvOUTSIDE(PL_compcv)) &&
458 CvPADLIST(compcv)))
459 compcv = NULL;
460 #endif /* <5.17.5 */
461 if(!compcv)
462 croak("can't set up lexical %s outside compilation",
463 vari_word);
464 return compcv;
465 }
466
467 #define setup_pad(compcv, name) THX_setup_pad(aTHX_ compcv, name)
THX_setup_pad(pTHX_ CV * compcv,char const * name)468 static void THX_setup_pad(pTHX_ CV *compcv, char const *name)
469 {
470 PADLIST *padlist = CvPADLIST(compcv);
471 PADNAMELIST *padname = PadlistNAMES(padlist);
472 PAD *padvar = PadlistARRAY(padlist)[1];
473 PADOFFSET ouroffset;
474 PADNAME *ourname;
475 SV *ourvar;
476 HV *stash;
477 ourvar = *av_fetch(padvar, PadMAX(padvar) + 1, 1);
478 SvPADMY_on(ourvar);
479 ouroffset = PadMAX(padvar);
480 #ifdef newPADNAMEpvn
481 ourname = newPADNAMEpvn(name, strlen(name));
482 #else
483 ourname = newSV_type(SVt_PADNAME);
484 sv_setpv(ourname, name);
485 #endif
486 SvPAD_OUR_on(ourname);
487 stash = name[0] == '$' ? stash_lex_sv :
488 name[0] == '@' ? stash_lex_av : stash_lex_hv;
489 SvOURSTASH_set(ourname, (HV*)SvREFCNT_inc((SV*)stash));
490 COP_SEQ_RANGE_LOW_set(ourname, PL_cop_seqmax);
491 COP_SEQ_RANGE_HIGH_set(ourname, pad_max());
492 PL_cop_seqmax++;
493 padnamelist_store(padname, ouroffset, ourname);
494 #ifdef PadnamelistMAXNAMED
495 PadnamelistMAXNAMED(padname) = ouroffset;
496 #endif /* PadnamelistMAXNAMED */
497 }
498
499 #define lookup_for_compilation(base_sigil, vari_word, name) \
500 THX_lookup_for_compilation(aTHX_ base_sigil, vari_word, name)
THX_lookup_for_compilation(pTHX_ char base_sigil,char const * vari_word,SV * name)501 static SV *THX_lookup_for_compilation(pTHX_ char base_sigil,
502 char const *vari_word, SV *name)
503 {
504 SV *key;
505 HE *he;
506 if(!sv_is_string(name)) croak("%s name is not a string", vari_word);
507 key = name_key(base_sigil, name);
508 if(!key) croak("malformed %s name", vari_word);
509 he = hv_fetch_ent(GvHV(PL_hintgv), key, 0, 0);
510 return he ? SvREFCNT_inc(HeVAL(he)) : &PL_sv_undef;
511 }
512
svt_scalar(svtype t)513 static int svt_scalar(svtype t)
514 {
515 switch(t) {
516 case SVt_NULL: case SVt_IV: case SVt_NV:
517 #if !PERL_VERSION_GE(5,11,0)
518 case SVt_RV:
519 #endif /* <5.11.0 */
520 case SVt_PV: case SVt_PVIV: case SVt_PVNV:
521 case SVt_PVMG: case SVt_PVLV: case SVt_PVGV:
522 #if PERL_VERSION_GE(5,11,0)
523 case SVt_REGEXP:
524 #endif /* >=5.11.0 */
525 return 1;
526 default:
527 return 0;
528 }
529 }
530
531 #define import(base_sigil, vari_word) THX_import(aTHX_ base_sigil, vari_word)
THX_import(pTHX_ char base_sigil,char const * vari_word)532 static void THX_import(pTHX_ char base_sigil, char const *vari_word)
533 {
534 dXSARGS;
535 CV *compcv;
536 int i;
537 SP -= items;
538 if(items < 1)
539 croak("too few arguments for import");
540 if(items == 1)
541 croak("%"SVf" does no default importation", SVfARG(ST(0)));
542 if(!(items & 1))
543 croak("import list for %"SVf
544 " must alternate name and reference", SVfARG(ST(0)));
545 compcv = find_compcv(vari_word);
546 PL_hints |= HINT_LOCALIZE_HH;
547 gv_HVadd(PL_hintgv);
548 for(i = 1; i != items; i += 2) {
549 SV *name = ST(i), *ref = ST(i+1), *key, *val;
550 svtype rt;
551 bool rok;
552 char const *vt;
553 char sigil;
554 HE *he;
555 if(!sv_is_string(name))
556 croak("%s name is not a string", vari_word);
557 key = name_key(base_sigil, name);
558 if(!key) croak("malformed %s name", vari_word);
559 sigil = SvPVX(key)[KEYPREFIXLEN];
560 rt = SvROK(ref) ? SvTYPE(SvRV(ref)) : SVt_LAST;
561 switch(sigil) {
562 case '$': rok = svt_scalar(rt); vt="scalar"; break;
563 case '@': rok = rt == SVt_PVAV; vt="array"; break;
564 case '%': rok = rt == SVt_PVHV; vt="hash"; break;
565 case '&': rok = rt == SVt_PVCV; vt="code"; break;
566 case '*': rok = rt == SVt_PVGV; vt="glob"; break;
567 default: rok = 0; vt = "wibble"; break;
568 }
569 if(!rok) croak("%s is not %s reference", vari_word, vt);
570 val = newRV_inc(SvRV(ref));
571 he = hv_store_ent(GvHV(PL_hintgv), key, val, 0);
572 if(he) {
573 val = HeVAL(he);
574 SvSETMAGIC(val);
575 } else {
576 SvREFCNT_dec(val);
577 }
578 if(char_attr[(U8)sigil] & CHAR_USEPAD)
579 setup_pad(compcv, SvPVX(key)+KEYPREFIXLEN);
580 }
581 PUTBACK;
582 }
583
584 #define unimport(base_sigil, vari_word) \
585 THX_unimport(aTHX_ base_sigil, vari_word)
THX_unimport(pTHX_ char base_sigil,char const * vari_word)586 static void THX_unimport(pTHX_ char base_sigil, char const *vari_word)
587 {
588 dXSARGS;
589 CV *compcv;
590 int i;
591 SP -= items;
592 if(items < 1)
593 croak("too few arguments for unimport");
594 if(items == 1)
595 croak("%"SVf" does no default unimportation", SVfARG(ST(0)));
596 compcv = find_compcv(vari_word);
597 PL_hints |= HINT_LOCALIZE_HH;
598 gv_HVadd(PL_hintgv);
599 for(i = 1; i != items; i++) {
600 SV *name = ST(i), *ref, *key;
601 char sigil;
602 if(!sv_is_string(name))
603 croak("%s name is not a string", vari_word);
604 key = name_key(base_sigil, name);
605 if(!key) croak("malformed %s name", vari_word);
606 sigil = SvPVX(key)[KEYPREFIXLEN];
607 if(i != items && (ref = ST(i+1), SvROK(ref))) {
608 HE *he;
609 SV *cref;
610 i++;
611 he = hv_fetch_ent(GvHV(PL_hintgv), key, 0, 0);
612 cref = he ? HeVAL(he) : &PL_sv_undef;
613 if(SvROK(cref) && SvRV(cref) != SvRV(ref))
614 continue;
615 }
616 (void) hv_delete_ent(GvHV(PL_hintgv), key, G_DISCARD, 0);
617 if(char_attr[(U8)sigil] & CHAR_USEPAD)
618 setup_pad(compcv, SvPVX(key)+KEYPREFIXLEN);
619 }
620 }
621
622 MODULE = Lexical::Var PACKAGE = Lexical::Var
623
624 PROTOTYPES: DISABLE
625
626 BOOT:
627 fake_sv = &PL_sv_undef;
628 fake_av = (SV*)newAV();
629 fake_hv = (SV*)newHV();
630 stash_lex_sv = gv_stashpvs(LEXPADPREFIX"$", 1);
631 stash_lex_av = gv_stashpvs(LEXPADPREFIX"@", 1);
632 stash_lex_hv = gv_stashpvs(LEXPADPREFIX"%", 1);
633 nxck_rv2sv = PL_check[OP_RV2SV]; PL_check[OP_RV2SV] = ck_rv2sv;
634 nxck_rv2av = PL_check[OP_RV2AV]; PL_check[OP_RV2AV] = ck_rv2av;
635 nxck_rv2hv = PL_check[OP_RV2HV]; PL_check[OP_RV2HV] = ck_rv2hv;
636 nxck_rv2cv = PL_check[OP_RV2CV]; PL_check[OP_RV2CV] = ck_rv2cv;
637 nxck_rv2gv = PL_check[OP_RV2GV]; PL_check[OP_RV2GV] = ck_rv2gv;
638
639 SV *
640 _variable_for_compilation(SV *classname, SV *name)
641 CODE:
642 PERL_UNUSED_VAR(classname);
643 RETVAL = lookup_for_compilation('N', "variable", name);
644 OUTPUT:
645 RETVAL
646
647 void
648 import(SV *classname, ...)
649 PPCODE:
650 PERL_UNUSED_VAR(classname);
651 PUSHMARK(SP);
652 /* the modified SP is intentionally lost here */
653 import('N', "variable");
654 SPAGAIN;
655
656 void
657 unimport(SV *classname, ...)
658 PPCODE:
659 PERL_UNUSED_VAR(classname);
660 PUSHMARK(SP);
661 /* the modified SP is intentionally lost here */
662 unimport('N', "variable");
663 SPAGAIN;
664
665 MODULE = Lexical::Var PACKAGE = Lexical::Sub
666
667 SV *
668 _sub_for_compilation(SV *classname, SV *name)
669 CODE:
670 PERL_UNUSED_VAR(classname);
671 RETVAL = lookup_for_compilation('&', "subroutine", name);
672 OUTPUT:
673 RETVAL
674
675 void
676 import(SV *classname, ...)
677 PPCODE:
678 PERL_UNUSED_VAR(classname);
679 PUSHMARK(SP);
680 /* the modified SP is intentionally lost here */
681 import('&', "subroutine");
682 SPAGAIN;
683
684 void
685 unimport(SV *classname, ...)
686 PPCODE:
687 PERL_UNUSED_VAR(classname);
688 PUSHMARK(SP);
689 /* the modified SP is intentionally lost here */
690 unimport('&', "subroutine");
691 SPAGAIN;
692