Commit | Line | Data |
---|---|---|
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 | ||
10 | typedef 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 | ||
20 | STATIC ptable *ab_op_map = NULL; | |
21 | ||
22 | #ifdef USE_ITHREADS | |
23 | STATIC perl_mutex ab_op_map_mutex; | |
24 | #endif | |
25 | ||
26 | STATIC 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 | ||
46 | STATIC 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 | ||
63 | STATIC 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 | ||
79 | STATIC 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 | ||
97 | STATIC 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 |
108 | STATIC 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 | ||
116 | STATIC 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 |
124 | old_ck(sassign); |
125 | old_ck(aassign); | |
126 | old_ck(aelem); | |
127 | old_ck(aslice); | |
128 | old_ck(lslice); | |
129 | old_ck(av2arylen); | |
130 | old_ck(splice); | |
131 | old_ck(keys); | |
132 | old_ck(each); | |
133 | old_ck(substr); | |
134 | old_ck(rindex); | |
135 | old_ck(index); | |
136 | old_ck(pos); | |
137 | ||
138 | STATIC 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 | ||
148 | STATIC 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)); |
b82b06b8 FC |
159 | cUNOPx(o)->op_first = newc; |
160 | op_free(oldc); | |
161 | } | |
162 | ||
163 | STATIC void ab_process_assignment(pTHX_ OP *left, OP *right) { | |
164 | #define ab_process_assignment(l, r) \ | |
165 | ab_process_assignment(aTHX_ (l), (r)) | |
166 | if (ab_op_is_dollar_bracket(left) && right->op_type == OP_CONST) { | |
167 | set_arybase_to(SvIV(cSVOPx_sv(right))); | |
168 | ab_neuter_dollar_bracket(left); | |
36b2db7e FC |
169 | Perl_ck_warner_d(aTHX_ |
170 | packWARN(WARN_DEPRECATED), "Use of assignment to $[ is deprecated" | |
171 | ); | |
b82b06b8 FC |
172 | } |
173 | } | |
174 | ||
175 | STATIC OP *ab_ck_sassign(pTHX_ OP *o) { | |
176 | o = (*ab_old_ck_sassign)(aTHX_ o); | |
2846acbf | 177 | if (o->op_type == OP_SASSIGN && FEATURE_ARYBASE_IS_ENABLED) { |
b82b06b8 FC |
178 | OP *right = cBINOPx(o)->op_first; |
179 | OP *left = right->op_sibling; | |
180 | if (left) ab_process_assignment(left, right); | |
b82b06b8 | 181 | } |
02523b6e | 182 | return o; |
b82b06b8 FC |
183 | } |
184 | ||
185 | STATIC OP *ab_ck_aassign(pTHX_ OP *o) { | |
186 | o = (*ab_old_ck_aassign)(aTHX_ o); | |
2846acbf | 187 | if (o->op_type == OP_AASSIGN && FEATURE_ARYBASE_IS_ENABLED) { |
b82b06b8 FC |
188 | OP *right = cBINOPx(o)->op_first; |
189 | OP *left = cBINOPx(right->op_sibling)->op_first->op_sibling; | |
190 | right = cBINOPx(right)->op_first->op_sibling; | |
191 | ab_process_assignment(left, right); | |
b82b06b8 | 192 | } |
02523b6e | 193 | return o; |
b82b06b8 FC |
194 | } |
195 | ||
196 | void | |
197 | tie(pTHX_ SV * const sv, SV * const obj, HV *const stash) | |
198 | { | |
199 | SV *rv = newSV_type(SVt_RV); | |
200 | ||
201 | SvRV_set(rv, obj ? SvREFCNT_inc_simple_NN(obj) : newSV(0)); | |
202 | SvROK_on(rv); | |
203 | sv_bless(rv, stash); | |
204 | ||
205 | sv_unmagic((SV *)sv, PERL_MAGIC_tiedscalar); | |
206 | sv_magic((SV *)sv, rv, PERL_MAGIC_tiedscalar, NULL, 0); | |
207 | SvREFCNT_dec(rv); /* As sv_magic increased it by one. */ | |
208 | } | |
209 | ||
210 | /* This function converts from base-based to 0-based an index to be passed | |
211 | as an argument. */ | |
212 | static IV | |
213 | adjust_index(IV index, IV base) | |
214 | { | |
215 | if (index >= base || index > -1) return index-base; | |
216 | return index; | |
217 | } | |
218 | /* This function converts from 0-based to base-based an index to | |
219 | be returned. */ | |
220 | static IV | |
221 | adjust_index_r(IV index, IV base) | |
222 | { | |
223 | return index + base; | |
224 | } | |
225 | ||
226 | #define replace_sv(sv,base) \ | |
227 | ((sv) = sv_2mortal(newSViv(adjust_index(SvIV(sv),base)))) | |
228 | #define replace_sv_r(sv,base) \ | |
229 | ((sv) = sv_2mortal(newSViv(adjust_index_r(SvIV(sv),base)))) | |
230 | ||
231 | static OP *ab_pp_basearg(pTHX) { | |
232 | dVAR; dSP; | |
233 | SV **firstp = NULL; | |
234 | SV **svp; | |
235 | UV count = 1; | |
236 | ab_op_info oi; | |
237 | ab_map_fetch(PL_op, &oi); | |
238 | ||
239 | switch (PL_op->op_type) { | |
240 | case OP_AELEM: | |
241 | firstp = SP; | |
242 | break; | |
243 | case OP_ASLICE: | |
244 | firstp = PL_stack_base + TOPMARK + 1; | |
245 | count = SP-firstp; | |
246 | break; | |
247 | case OP_LSLICE: | |
60aa0b5d FC |
248 | firstp = PL_stack_base + *(PL_markstack_ptr-1)+1; |
249 | count = TOPMARK - *(PL_markstack_ptr-1); | |
b82b06b8 FC |
250 | if (GIMME != G_ARRAY) { |
251 | firstp += count-1; | |
252 | count = 1; | |
253 | } | |
254 | break; | |
255 | case OP_SPLICE: | |
256 | if (SP - PL_stack_base - TOPMARK >= 2) | |
257 | firstp = PL_stack_base + TOPMARK + 2; | |
258 | else count = 0; | |
259 | break; | |
260 | case OP_SUBSTR: | |
261 | firstp = SP-(PL_op->op_private & 7)+2; | |
262 | break; | |
263 | default: | |
264 | DIE(aTHX_ | |
265 | "panic: invalid op type for arybase.xs:ab_pp_basearg: %d", | |
266 | PL_op->op_type); | |
267 | } | |
268 | svp = firstp; | |
269 | while (count--) replace_sv(*svp,oi.base), svp++; | |
270 | return (*oi.old_pp)(aTHX); | |
271 | } | |
272 | ||
273 | static OP *ab_pp_av2arylen(pTHX) { | |
274 | dSP; dVAR; | |
275 | SV *sv; | |
276 | ab_op_info oi; | |
277 | OP *ret; | |
278 | ab_map_fetch(PL_op, &oi); | |
279 | ret = (*oi.old_pp)(aTHX); | |
280 | if (PL_op->op_flags & OPf_MOD || LVRET) { | |
281 | sv = newSV(0); | |
282 | tie(aTHX_ sv, TOPs, gv_stashpv("arybase::mg",1)); | |
283 | SETs(sv); | |
284 | } | |
285 | else { | |
286 | SvGETMAGIC(TOPs); | |
287 | if (SvOK(TOPs)) replace_sv_r(TOPs, oi.base); | |
288 | } | |
289 | return ret; | |
290 | } | |
291 | ||
292 | static OP *ab_pp_keys(pTHX) { | |
293 | dVAR; dSP; | |
294 | ab_op_info oi; | |
295 | OP *retval; | |
296 | const I32 offset = SP - PL_stack_base; | |
297 | SV **svp; | |
298 | ab_map_fetch(PL_op, &oi); | |
299 | retval = (*oi.old_pp)(aTHX); | |
300 | if (GIMME_V == G_SCALAR) return retval; | |
301 | SPAGAIN; | |
302 | svp = PL_stack_base + offset; | |
303 | while (svp <= SP) replace_sv_r(*svp,oi.base), ++svp; | |
304 | return retval; | |
305 | } | |
306 | ||
307 | static OP *ab_pp_each(pTHX) { | |
308 | dVAR; dSP; | |
309 | ab_op_info oi; | |
310 | OP *retval; | |
311 | const I32 offset = SP - PL_stack_base; | |
312 | ab_map_fetch(PL_op, &oi); | |
313 | retval = (*oi.old_pp)(aTHX); | |
314 | SPAGAIN; | |
315 | if (GIMME_V == G_SCALAR) { | |
316 | if (SvOK(TOPs)) replace_sv_r(TOPs,oi.base); | |
317 | } | |
318 | else if (offset < SP - PL_stack_base) replace_sv_r(TOPm1s,oi.base); | |
319 | return retval; | |
320 | } | |
321 | ||
322 | static OP *ab_pp_index(pTHX) { | |
323 | dVAR; dSP; | |
324 | ab_op_info oi; | |
325 | OP *retval; | |
326 | ab_map_fetch(PL_op, &oi); | |
327 | if (MAXARG == 3 && TOPs) replace_sv(TOPs,oi.base); | |
328 | retval = (*oi.old_pp)(aTHX); | |
329 | SPAGAIN; | |
330 | replace_sv_r(TOPs,oi.base); | |
331 | return retval; | |
332 | } | |
333 | ||
334 | static OP *ab_ck_base(pTHX_ OP *o) | |
335 | { | |
336 | OP * (*old_ck)(pTHX_ OP *o) = 0; | |
337 | OP * (*new_pp)(pTHX) = ab_pp_basearg; | |
338 | switch (o->op_type) { | |
339 | case OP_AELEM : old_ck = ab_old_ck_aelem ; break; | |
340 | case OP_ASLICE : old_ck = ab_old_ck_aslice ; break; | |
341 | case OP_LSLICE : old_ck = ab_old_ck_lslice ; break; | |
342 | case OP_AV2ARYLEN: old_ck = ab_old_ck_av2arylen; break; | |
343 | case OP_SPLICE : old_ck = ab_old_ck_splice ; break; | |
344 | case OP_KEYS : old_ck = ab_old_ck_keys ; break; | |
345 | case OP_EACH : old_ck = ab_old_ck_each ; break; | |
346 | case OP_SUBSTR : old_ck = ab_old_ck_substr ; break; | |
347 | case OP_RINDEX : old_ck = ab_old_ck_rindex ; break; | |
348 | case OP_INDEX : old_ck = ab_old_ck_index ; break; | |
349 | case OP_POS : old_ck = ab_old_ck_pos ; break; | |
a3f353cf RU |
350 | default: |
351 | DIE(aTHX_ | |
352 | "panic: invalid op type for arybase.xs:ab_ck_base: %d", | |
353 | PL_op->op_type); | |
b82b06b8 FC |
354 | } |
355 | o = (*old_ck)(aTHX_ o); | |
2846acbf | 356 | if (!FEATURE_ARYBASE_IS_ENABLED) return o; |
b82b06b8 FC |
357 | /* We need two switch blocks, as the type may have changed. */ |
358 | switch (o->op_type) { | |
359 | case OP_AELEM : | |
360 | case OP_ASLICE : | |
361 | case OP_LSLICE : | |
362 | case OP_SPLICE : | |
363 | case OP_SUBSTR : break; | |
364 | case OP_POS : | |
365 | case OP_AV2ARYLEN: new_pp = ab_pp_av2arylen ; break; | |
366 | case OP_AKEYS : new_pp = ab_pp_keys ; break; | |
367 | case OP_AEACH : new_pp = ab_pp_each ; break; | |
368 | case OP_RINDEX : | |
369 | case OP_INDEX : new_pp = ab_pp_index ; break; | |
370 | default: return o; | |
371 | } | |
372 | { | |
373 | IV const base = current_base(); | |
374 | if (base) { | |
375 | ab_map_store(o, o->op_ppaddr, base); | |
376 | o->op_ppaddr = new_pp; | |
377 | /* Break the aelemfast optimisation */ | |
378 | if (o->op_type == OP_AELEM && | |
379 | cBINOPo->op_first->op_sibling->op_type == OP_CONST) { | |
380 | cBINOPo->op_first->op_sibling | |
381 | = newUNOP(OP_NULL,0,cBINOPo->op_first->op_sibling); | |
382 | } | |
383 | } | |
384 | else ab_map_delete(o); | |
385 | } | |
386 | return o; | |
387 | } | |
388 | ||
389 | ||
390 | STATIC U32 ab_initialized = 0; | |
391 | ||
392 | /* --- XS ------------------------------------------------------------- */ | |
393 | ||
394 | MODULE = arybase PACKAGE = arybase | |
395 | PROTOTYPES: DISABLE | |
396 | ||
397 | BOOT: | |
398 | { | |
399 | GV *const gv = gv_fetchpvn("[", 1, GV_ADDMULTI|GV_NOTQUAL, SVt_PV); | |
7d69d4a6 | 400 | sv_unmagic(GvSV(gv), PERL_MAGIC_sv); /* This is *our* scalar now! */ |
b82b06b8 FC |
401 | tie(aTHX_ GvSV(gv), NULL, GvSTASH(CvGV(cv))); |
402 | ||
403 | if (!ab_initialized++) { | |
404 | ab_op_map = ptable_new(); | |
405 | #ifdef USE_ITHREADS | |
406 | MUTEX_INIT(&ab_op_map_mutex); | |
407 | #endif | |
a7817fa3 FC |
408 | #define check(uc,lc,ck) \ |
409 | wrap_op_checker(OP_##uc, ab_ck_##ck, &ab_old_ck_##lc) | |
b82b06b8 FC |
410 | check(SASSIGN, sassign, sassign); |
411 | check(AASSIGN, aassign, aassign); | |
412 | check(AELEM, aelem, base); | |
413 | check(ASLICE, aslice, base); | |
414 | check(LSLICE, lslice, base); | |
415 | check(AV2ARYLEN,av2arylen,base); | |
416 | check(SPLICE, splice, base); | |
417 | check(KEYS, keys, base); | |
418 | check(EACH, each, base); | |
419 | check(SUBSTR, substr, base); | |
420 | check(RINDEX, rindex, base); | |
421 | check(INDEX, index, base); | |
422 | check(POS, pos, base); | |
423 | } | |
424 | } | |
425 | ||
426 | void | |
427 | FETCH(...) | |
428 | PREINIT: | |
2846acbf | 429 | SV *ret = FEATURE_ARYBASE_IS_ENABLED |
7d69d4a6 FC |
430 | ? cop_hints_fetch_pvs(PL_curcop, "$[", 0) |
431 | : 0; | |
b82b06b8 | 432 | PPCODE: |
7d69d4a6 | 433 | if (!ret || !SvOK(ret)) mXPUSHi(0); |
b82b06b8 FC |
434 | else XPUSHs(ret); |
435 | ||
436 | void | |
437 | STORE(SV *sv, IV newbase) | |
b82b06b8 | 438 | CODE: |
3b32020f | 439 | PERL_UNUSED_VAR(sv); |
2846acbf | 440 | if (FEATURE_ARYBASE_IS_ENABLED) { |
7d69d4a6 | 441 | SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0); |
b82b06b8 FC |
442 | if (SvOK(base) ? SvIV(base) == newbase : !newbase) XSRETURN_EMPTY; |
443 | Perl_croak(aTHX_ "That use of $[ is unsupported"); | |
7d69d4a6 FC |
444 | } |
445 | else if (newbase) | |
446 | Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible"); | |
b82b06b8 FC |
447 | |
448 | ||
449 | MODULE = arybase PACKAGE = arybase::mg | |
450 | PROTOTYPES: DISABLE | |
451 | ||
452 | void | |
453 | FETCH(SV *sv) | |
454 | PPCODE: | |
455 | if (!SvROK(sv) || SvTYPE(SvRV(sv)) >= SVt_PVAV) | |
456 | Perl_croak(aTHX_ "Not a SCALAR reference"); | |
457 | { | |
2846acbf | 458 | SV *base = FEATURE_ARYBASE_IS_ENABLED |
7d69d4a6 FC |
459 | ? cop_hints_fetch_pvs(PL_curcop, "$[", 0) |
460 | : 0; | |
b82b06b8 FC |
461 | SvGETMAGIC(SvRV(sv)); |
462 | if (!SvOK(SvRV(sv))) XSRETURN_UNDEF; | |
463 | mXPUSHi(adjust_index_r( | |
7d69d4a6 | 464 | SvIV_nomg(SvRV(sv)), base&&SvOK(base)?SvIV(base):0 |
b82b06b8 FC |
465 | )); |
466 | } | |
467 | ||
468 | void | |
469 | STORE(SV *sv, SV *newbase) | |
470 | CODE: | |
471 | if (!SvROK(sv) || SvTYPE(SvRV(sv)) >= SVt_PVAV) | |
472 | Perl_croak(aTHX_ "Not a SCALAR reference"); | |
473 | { | |
2846acbf | 474 | SV *base = FEATURE_ARYBASE_IS_ENABLED |
7d69d4a6 FC |
475 | ? cop_hints_fetch_pvs(PL_curcop, "$[", 0) |
476 | : 0; | |
b82b06b8 FC |
477 | SvGETMAGIC(newbase); |
478 | if (!SvOK(newbase)) SvSetMagicSV(SvRV(sv),&PL_sv_undef); | |
479 | else | |
480 | sv_setiv_mg( | |
481 | SvRV(sv), | |
7d69d4a6 FC |
482 | adjust_index( |
483 | SvIV_nomg(newbase), base&&SvOK(base)?SvIV(base):0 | |
484 | ) | |
b82b06b8 FC |
485 | ); |
486 | } |