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