This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
arybase.xs: Always check the op type in ck_*
[perl5.git] / ext / arybase / arybase.xs
CommitLineData
b82b06b8
FC
1#define PERL_NO_GET_CONTEXT /* we want efficiency */
2#include "EXTERN.h"
3#include "perl.h"
4#include "XSUB.h"
5
6/* ... op => info map ................................................. */
7
8typedef struct {
9 OP *(*old_pp)(pTHX);
10 IV base;
11} ab_op_info;
12
13#define PTABLE_NAME ptable_map
14#define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
15#include "ptable.h"
16#define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))
17
18STATIC ptable *ab_op_map = NULL;
19
20#ifdef USE_ITHREADS
21STATIC perl_mutex ab_op_map_mutex;
22#endif
23
24STATIC const ab_op_info *ab_map_fetch(const OP *o, ab_op_info *oi) {
25 const ab_op_info *val;
26
27#ifdef USE_ITHREADS
28 MUTEX_LOCK(&ab_op_map_mutex);
29#endif
30
f39efbfa 31 val = (ab_op_info *)ptable_fetch(ab_op_map, o);
b82b06b8
FC
32 if (val) {
33 *oi = *val;
34 val = oi;
35 }
36
37#ifdef USE_ITHREADS
38 MUTEX_UNLOCK(&ab_op_map_mutex);
39#endif
40
41 return val;
42}
43
44STATIC const ab_op_info *ab_map_store_locked(
45 pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), IV base
46) {
47#define ab_map_store_locked(O, PP, B) \
48 ab_map_store_locked(aPTBLMS_ (O), (PP), (B))
49 ab_op_info *oi;
50
f39efbfa
TC
51 if (!(oi = (ab_op_info *)ptable_fetch(ab_op_map, o))) {
52 oi = (ab_op_info *)PerlMemShared_malloc(sizeof *oi);
b82b06b8
FC
53 ptable_map_store(ab_op_map, o, oi);
54 }
55
56 oi->old_pp = old_pp;
57 oi->base = base;
58 return oi;
59}
60
61STATIC void ab_map_store(
62 pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), IV base)
63{
64#define ab_map_store(O, PP, B) ab_map_store(aPTBLMS_ (O),(PP),(B))
65
66#ifdef USE_ITHREADS
67 MUTEX_LOCK(&ab_op_map_mutex);
68#endif
69
70 ab_map_store_locked(o, old_pp, base);
71
72#ifdef USE_ITHREADS
73 MUTEX_UNLOCK(&ab_op_map_mutex);
74#endif
75}
76
77STATIC void ab_map_delete(pTHX_ const OP *o) {
78#define ab_map_delete(O) ab_map_delete(aTHX_ (O))
79#ifdef USE_ITHREADS
80 MUTEX_LOCK(&ab_op_map_mutex);
81#endif
82
83 ptable_map_store(ab_op_map, o, NULL);
84
85#ifdef USE_ITHREADS
86 MUTEX_UNLOCK(&ab_op_map_mutex);
87#endif
88}
89
90/* ... $[ Implementation .............................................. */
91
92#define hintkey "$["
93#define hintkey_len (sizeof(hintkey)-1)
94
95STATIC SV * ab_hint(pTHX_ const bool create) {
96#define ab_hint(c) ab_hint(aTHX_ c)
97 dVAR;
98 SV **val
99 = hv_fetch(GvHV(PL_hintgv), hintkey, hintkey_len, create);
100 if (!val)
101 return 0;
102 return *val;
103}
104
105STATIC IV current_base(pTHX) {
106#define current_base() current_base(aTHX)
107 SV *hsv = ab_hint(0);
108 if (!hsv || !SvOK(hsv)) return 0;
109 return SvIV(hsv);
110}
111
112STATIC void set_arybase_to(pTHX_ IV base) {
113#define set_arybase_to(base) set_arybase_to(aTHX_ (base))
114 dVAR;
115 SV *hsv = ab_hint(1);
116 sv_setiv_mg(hsv, base);
117}
118
546dd830 119#define old_ck(opname) STATIC OP *(*ab_old_ck_##opname)(pTHX_ OP *) = 0
b82b06b8
FC
120old_ck(sassign);
121old_ck(aassign);
122old_ck(aelem);
123old_ck(aslice);
124old_ck(lslice);
125old_ck(av2arylen);
126old_ck(splice);
127old_ck(keys);
128old_ck(each);
129old_ck(substr);
130old_ck(rindex);
131old_ck(index);
132old_ck(pos);
133
134STATIC bool ab_op_is_dollar_bracket(pTHX_ OP *o) {
135#define ab_op_is_dollar_bracket(o) ab_op_is_dollar_bracket(aTHX_ (o))
136 OP *c;
137 return o->op_type == OP_RV2SV && (o->op_flags & OPf_KIDS)
138 && (c = cUNOPx(o)->op_first)
139 && c->op_type == OP_GV
140 && strEQ(GvNAME(cGVOPx_gv(c)), "[");
141}
142
143STATIC void ab_neuter_dollar_bracket(pTHX_ OP *o) {
144#define ab_neuter_dollar_bracket(o) ab_neuter_dollar_bracket(aTHX_ (o))
145 OP *oldc, *newc;
146 /*
147 * Must replace the core's $[ with something that can accept assignment
148 * of non-zero value and can be local()ised. Simplest thing is a
149 * different global variable.
150 */
151 oldc = cUNOPx(o)->op_first;
152 newc = newGVOP(OP_GV, 0,
153 gv_fetchpvs("arybase::[", GV_ADDMULTI, SVt_PVGV));
154 cUNOPx(o)->op_first = newc;
155 op_free(oldc);
156}
157
158STATIC void ab_process_assignment(pTHX_ OP *left, OP *right) {
159#define ab_process_assignment(l, r) \
160 ab_process_assignment(aTHX_ (l), (r))
161 if (ab_op_is_dollar_bracket(left) && right->op_type == OP_CONST) {
162 set_arybase_to(SvIV(cSVOPx_sv(right)));
163 ab_neuter_dollar_bracket(left);
164 }
165}
166
167STATIC OP *ab_ck_sassign(pTHX_ OP *o) {
168 o = (*ab_old_ck_sassign)(aTHX_ o);
02523b6e 169 if (o->op_type == OP_SASSIGN) {
b82b06b8
FC
170 OP *right = cBINOPx(o)->op_first;
171 OP *left = right->op_sibling;
172 if (left) ab_process_assignment(left, right);
b82b06b8 173 }
02523b6e 174 return o;
b82b06b8
FC
175}
176
177STATIC OP *ab_ck_aassign(pTHX_ OP *o) {
178 o = (*ab_old_ck_aassign)(aTHX_ o);
02523b6e 179 if (o->op_type == OP_AASSIGN) {
b82b06b8
FC
180 OP *right = cBINOPx(o)->op_first;
181 OP *left = cBINOPx(right->op_sibling)->op_first->op_sibling;
182 right = cBINOPx(right)->op_first->op_sibling;
183 ab_process_assignment(left, right);
b82b06b8 184 }
02523b6e 185 return o;
b82b06b8
FC
186}
187
188void
189tie(pTHX_ SV * const sv, SV * const obj, HV *const stash)
190{
191 SV *rv = newSV_type(SVt_RV);
192
193 SvRV_set(rv, obj ? SvREFCNT_inc_simple_NN(obj) : newSV(0));
194 SvROK_on(rv);
195 sv_bless(rv, stash);
196
197 sv_unmagic((SV *)sv, PERL_MAGIC_tiedscalar);
198 sv_magic((SV *)sv, rv, PERL_MAGIC_tiedscalar, NULL, 0);
199 SvREFCNT_dec(rv); /* As sv_magic increased it by one. */
200}
201
202/* This function converts from base-based to 0-based an index to be passed
203 as an argument. */
204static IV
205adjust_index(IV index, IV base)
206{
207 if (index >= base || index > -1) return index-base;
208 return index;
209}
210/* This function converts from 0-based to base-based an index to
211 be returned. */
212static IV
213adjust_index_r(IV index, IV base)
214{
215 return index + base;
216}
217
218#define replace_sv(sv,base) \
219 ((sv) = sv_2mortal(newSViv(adjust_index(SvIV(sv),base))))
220#define replace_sv_r(sv,base) \
221 ((sv) = sv_2mortal(newSViv(adjust_index_r(SvIV(sv),base))))
222
223static OP *ab_pp_basearg(pTHX) {
224 dVAR; dSP;
225 SV **firstp = NULL;
226 SV **svp;
227 UV count = 1;
228 ab_op_info oi;
229 ab_map_fetch(PL_op, &oi);
230
231 switch (PL_op->op_type) {
232 case OP_AELEM:
233 firstp = SP;
234 break;
235 case OP_ASLICE:
236 firstp = PL_stack_base + TOPMARK + 1;
237 count = SP-firstp;
238 break;
239 case OP_LSLICE:
240 firstp = PL_stack_base + *(PL_markstack_ptr-2)+1;
241 count = TOPMARK - *(PL_markstack_ptr-2);
242 if (GIMME != G_ARRAY) {
243 firstp += count-1;
244 count = 1;
245 }
246 break;
247 case OP_SPLICE:
248 if (SP - PL_stack_base - TOPMARK >= 2)
249 firstp = PL_stack_base + TOPMARK + 2;
250 else count = 0;
251 break;
252 case OP_SUBSTR:
253 firstp = SP-(PL_op->op_private & 7)+2;
254 break;
255 default:
256 DIE(aTHX_
257 "panic: invalid op type for arybase.xs:ab_pp_basearg: %d",
258 PL_op->op_type);
259 }
260 svp = firstp;
261 while (count--) replace_sv(*svp,oi.base), svp++;
262 return (*oi.old_pp)(aTHX);
263}
264
265static OP *ab_pp_av2arylen(pTHX) {
266 dSP; dVAR;
267 SV *sv;
268 ab_op_info oi;
269 OP *ret;
270 ab_map_fetch(PL_op, &oi);
271 ret = (*oi.old_pp)(aTHX);
272 if (PL_op->op_flags & OPf_MOD || LVRET) {
273 sv = newSV(0);
274 tie(aTHX_ sv, TOPs, gv_stashpv("arybase::mg",1));
275 SETs(sv);
276 }
277 else {
278 SvGETMAGIC(TOPs);
279 if (SvOK(TOPs)) replace_sv_r(TOPs, oi.base);
280 }
281 return ret;
282}
283
284static OP *ab_pp_keys(pTHX) {
285 dVAR; dSP;
286 ab_op_info oi;
287 OP *retval;
288 const I32 offset = SP - PL_stack_base;
289 SV **svp;
290 ab_map_fetch(PL_op, &oi);
291 retval = (*oi.old_pp)(aTHX);
292 if (GIMME_V == G_SCALAR) return retval;
293 SPAGAIN;
294 svp = PL_stack_base + offset;
295 while (svp <= SP) replace_sv_r(*svp,oi.base), ++svp;
296 return retval;
297}
298
299static OP *ab_pp_each(pTHX) {
300 dVAR; dSP;
301 ab_op_info oi;
302 OP *retval;
303 const I32 offset = SP - PL_stack_base;
304 ab_map_fetch(PL_op, &oi);
305 retval = (*oi.old_pp)(aTHX);
306 SPAGAIN;
307 if (GIMME_V == G_SCALAR) {
308 if (SvOK(TOPs)) replace_sv_r(TOPs,oi.base);
309 }
310 else if (offset < SP - PL_stack_base) replace_sv_r(TOPm1s,oi.base);
311 return retval;
312}
313
314static OP *ab_pp_index(pTHX) {
315 dVAR; dSP;
316 ab_op_info oi;
317 OP *retval;
318 ab_map_fetch(PL_op, &oi);
319 if (MAXARG == 3 && TOPs) replace_sv(TOPs,oi.base);
320 retval = (*oi.old_pp)(aTHX);
321 SPAGAIN;
322 replace_sv_r(TOPs,oi.base);
323 return retval;
324}
325
326static OP *ab_ck_base(pTHX_ OP *o)
327{
328 OP * (*old_ck)(pTHX_ OP *o) = 0;
329 OP * (*new_pp)(pTHX) = ab_pp_basearg;
330 switch (o->op_type) {
331 case OP_AELEM : old_ck = ab_old_ck_aelem ; break;
332 case OP_ASLICE : old_ck = ab_old_ck_aslice ; break;
333 case OP_LSLICE : old_ck = ab_old_ck_lslice ; break;
334 case OP_AV2ARYLEN: old_ck = ab_old_ck_av2arylen; break;
335 case OP_SPLICE : old_ck = ab_old_ck_splice ; break;
336 case OP_KEYS : old_ck = ab_old_ck_keys ; break;
337 case OP_EACH : old_ck = ab_old_ck_each ; break;
338 case OP_SUBSTR : old_ck = ab_old_ck_substr ; break;
339 case OP_RINDEX : old_ck = ab_old_ck_rindex ; break;
340 case OP_INDEX : old_ck = ab_old_ck_index ; break;
341 case OP_POS : old_ck = ab_old_ck_pos ; break;
342 }
343 o = (*old_ck)(aTHX_ o);
344 /* We need two switch blocks, as the type may have changed. */
345 switch (o->op_type) {
346 case OP_AELEM :
347 case OP_ASLICE :
348 case OP_LSLICE :
349 case OP_SPLICE :
350 case OP_SUBSTR : break;
351 case OP_POS :
352 case OP_AV2ARYLEN: new_pp = ab_pp_av2arylen ; break;
353 case OP_AKEYS : new_pp = ab_pp_keys ; break;
354 case OP_AEACH : new_pp = ab_pp_each ; break;
355 case OP_RINDEX :
356 case OP_INDEX : new_pp = ab_pp_index ; break;
357 default: return o;
358 }
359 {
360 IV const base = current_base();
361 if (base) {
362 ab_map_store(o, o->op_ppaddr, base);
363 o->op_ppaddr = new_pp;
364 /* Break the aelemfast optimisation */
365 if (o->op_type == OP_AELEM &&
366 cBINOPo->op_first->op_sibling->op_type == OP_CONST) {
367 cBINOPo->op_first->op_sibling
368 = newUNOP(OP_NULL,0,cBINOPo->op_first->op_sibling);
369 }
370 }
371 else ab_map_delete(o);
372 }
373 return o;
374}
375
376
377STATIC U32 ab_initialized = 0;
378
379/* --- XS ------------------------------------------------------------- */
380
381MODULE = arybase PACKAGE = arybase
382PROTOTYPES: DISABLE
383
384BOOT:
385{
386 GV *const gv = gv_fetchpvn("[", 1, GV_ADDMULTI|GV_NOTQUAL, SVt_PV);
387 tie(aTHX_ GvSV(gv), NULL, GvSTASH(CvGV(cv)));
388
389 if (!ab_initialized++) {
390 ab_op_map = ptable_new();
391#ifdef USE_ITHREADS
392 MUTEX_INIT(&ab_op_map_mutex);
393#endif
394#define check(uc,lc,ck) ab_old_ck_##lc = PL_check[OP_##uc]; \
395 PL_check[OP_##uc] = ab_ck_##ck
396 check(SASSIGN, sassign, sassign);
397 check(AASSIGN, aassign, aassign);
398 check(AELEM, aelem, base);
399 check(ASLICE, aslice, base);
400 check(LSLICE, lslice, base);
401 check(AV2ARYLEN,av2arylen,base);
402 check(SPLICE, splice, base);
403 check(KEYS, keys, base);
404 check(EACH, each, base);
405 check(SUBSTR, substr, base);
406 check(RINDEX, rindex, base);
407 check(INDEX, index, base);
408 check(POS, pos, base);
409 }
410}
411
412void
413FETCH(...)
414 PREINIT:
415 SV *ret = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
416 PPCODE:
417 if (!SvOK(ret)) mXPUSHi(0);
418 else XPUSHs(ret);
419
420void
421STORE(SV *sv, IV newbase)
422 PREINIT:
423 SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
424 CODE:
425 if (SvOK(base) ? SvIV(base) == newbase : !newbase) XSRETURN_EMPTY;
426 Perl_croak(aTHX_ "That use of $[ is unsupported");
427
428
429MODULE = arybase PACKAGE = arybase::mg
430PROTOTYPES: DISABLE
431
432void
433FETCH(SV *sv)
434 PPCODE:
435 if (!SvROK(sv) || SvTYPE(SvRV(sv)) >= SVt_PVAV)
436 Perl_croak(aTHX_ "Not a SCALAR reference");
437 {
438 SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
439 SvGETMAGIC(SvRV(sv));
440 if (!SvOK(SvRV(sv))) XSRETURN_UNDEF;
441 mXPUSHi(adjust_index_r(
442 SvIV_nomg(SvRV(sv)), SvOK(base)?SvIV(base):0
443 ));
444 }
445
446void
447STORE(SV *sv, SV *newbase)
448 CODE:
449 if (!SvROK(sv) || SvTYPE(SvRV(sv)) >= SVt_PVAV)
450 Perl_croak(aTHX_ "Not a SCALAR reference");
451 {
452 SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
453 SvGETMAGIC(newbase);
454 if (!SvOK(newbase)) SvSetMagicSV(SvRV(sv),&PL_sv_undef);
455 else
456 sv_setiv_mg(
457 SvRV(sv),
458 adjust_index(SvIV_nomg(newbase),SvOK(base)?SvIV(base):0)
459 );
460 }