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