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
1 #define PERL_NO_GET_CONTEXT     /* we want efficiency */
2 #define PERL_EXT
3 #include "EXTERN.h"
4 #include "perl.h"
5 #include "XSUB.h"
6 #include "feature.h"
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
33  val = (ab_op_info *)ptable_fetch(ab_op_map, o);
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
53  if (!(oi = (ab_op_info *)ptable_fetch(ab_op_map, o))) {
54   oi = (ab_op_info *)PerlMemShared_malloc(sizeof *oi);
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
107 /* current base at compile time */
108 STATIC IV current_base(pTHX) {
109 #define current_base() current_base(aTHX)
110  SV *hsv = ab_hint(0);
111  assert(FEATURE_ARYBASE_IS_ENABLED);
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
123 #define old_ck(opname) STATIC OP *(*ab_old_ck_##opname)(pTHX_ OP *) = 0
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
144   && GvSTASH(cGVOPx_gv(c)) == PL_defstash
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,
158    gv_fetchpvs("arybase::leftbrack", GV_ADDMULTI, SVt_PVGV));
159  /* replace oldc with newc */
160  op_sibling_splice(o, NULL, 1, newc);
161  op_free(oldc);
162 }
163
164 STATIC 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);
170   Perl_ck_warner_d(aTHX_
171    packWARN(WARN_DEPRECATED), "Use of assignment to $[ is deprecated"
172   );
173  }
174 }
175
176 STATIC OP *ab_ck_sassign(pTHX_ OP *o) {
177  o = (*ab_old_ck_sassign)(aTHX_ o);
178  if (o->op_type == OP_SASSIGN && FEATURE_ARYBASE_IS_ENABLED) {
179   OP *right = cBINOPx(o)->op_first;
180   OP *left = OpSIBLING(right);
181   if (left) ab_process_assignment(left, right);
182  }
183  return o;
184 }
185
186 STATIC OP *ab_ck_aassign(pTHX_ OP *o) {
187  o = (*ab_old_ck_aassign)(aTHX_ o);
188  if (o->op_type == OP_AASSIGN && FEATURE_ARYBASE_IS_ENABLED) {
189   OP *right = cBINOPx(o)->op_first;
190   OP *left = OpSIBLING(right);
191   left = OpSIBLING(cBINOPx(left)->op_first);
192   right = OpSIBLING(cBINOPx(right)->op_first);
193   ab_process_assignment(left, right);
194  }
195  return o;
196 }
197
198 STATIC void
199 tie(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. */
214 static IV
215 adjust_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. */
222 static IV
223 adjust_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
233 static OP *ab_pp_basearg(pTHX) {
234  dVAR; dSP;
235  SV **firstp = NULL;
236  SV **svp;
237  UV count = 1;
238  ab_op_info oi;
239  Zero(&oi, 1, ab_op_info);
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:
251   firstp = PL_stack_base + *(PL_markstack_ptr-1)+1;
252   count = TOPMARK - *(PL_markstack_ptr-1);
253   if (GIMME_V != G_ARRAY) {
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
276 static OP *ab_pp_av2arylen(pTHX) {
277  dSP; dVAR;
278  SV *sv;
279  ab_op_info oi;
280  OP *ret;
281  Zero(&oi, 1, ab_op_info);
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
296 static 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;
302  Zero(&oi, 1, ab_op_info);
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
312 static OP *ab_pp_each(pTHX) {
313  dVAR; dSP;
314  ab_op_info oi;
315  OP *retval;
316  const I32 offset = SP - PL_stack_base;
317  Zero(&oi, 1, ab_op_info);
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
328 static OP *ab_pp_index(pTHX) {
329  dVAR; dSP;
330  ab_op_info oi;
331  OP *retval;
332  Zero(&oi, 1, ab_op_info);
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
341 static 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;
357  default:
358   DIE(aTHX_
359      "panic: invalid op type for arybase.xs:ab_ck_base: %d",
360       PL_op->op_type);
361  }
362  o = (*old_ck)(aTHX_ o);
363  if (!FEATURE_ARYBASE_IS_ENABLED) return o;
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 */
385    if (o->op_type == OP_AELEM) {
386     OP *const first = cBINOPo->op_first;
387     OP *second = OpSIBLING(first);
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);
395     }
396    }
397   }
398   else ab_map_delete(o);
399  }
400  return o;
401 }
402
403
404 STATIC U32 ab_initialized = 0;
405
406 /* --- XS ------------------------------------------------------------- */
407
408 MODULE = arybase        PACKAGE = arybase
409 PROTOTYPES: DISABLE
410
411 BOOT:
412 {
413     if (!ab_initialized++) {
414         ab_op_map = ptable_new();
415 #ifdef USE_ITHREADS
416         MUTEX_INIT(&ab_op_map_mutex);
417 #endif
418 #define check(uc,lc,ck) \
419                 wrap_op_checker(OP_##uc, ab_ck_##ck, &ab_old_ck_##lc)
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
436 void
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
446 void
447 FETCH(...)
448     PREINIT:
449         SV *ret = FEATURE_ARYBASE_IS_ENABLED
450                    ? cop_hints_fetch_pvs(PL_curcop, "$[", 0)
451                    : 0;
452     PPCODE:
453         if (!ret || !SvOK(ret)) mXPUSHi(0);
454         else XPUSHs(ret);
455
456 void
457 STORE(SV *sv, IV newbase)
458     CODE:
459       PERL_UNUSED_VAR(sv);
460       if (FEATURE_ARYBASE_IS_ENABLED) {
461         SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
462         if (SvOK(base) ? SvIV(base) == newbase : !newbase) XSRETURN_EMPTY;
463         Perl_croak(aTHX_ "That use of $[ is unsupported");
464       }
465       else if (newbase)
466         Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
467
468
469 MODULE = arybase        PACKAGE = arybase::mg
470 PROTOTYPES: DISABLE
471
472 void
473 FETCH(SV *sv)
474     PPCODE:
475         if (!SvROK(sv) || SvTYPE(SvRV(sv)) >= SVt_PVAV)
476             Perl_croak(aTHX_ "Not a SCALAR reference");
477         {
478             SV *base = FEATURE_ARYBASE_IS_ENABLED
479                          ? cop_hints_fetch_pvs(PL_curcop, "$[", 0)
480                          : 0;
481             SvGETMAGIC(SvRV(sv));
482             if (!SvOK(SvRV(sv))) XSRETURN_UNDEF;
483             mXPUSHi(adjust_index_r(
484                 SvIV_nomg(SvRV(sv)), base&&SvOK(base)?SvIV(base):0
485             ));
486         }
487
488 void
489 STORE(SV *sv, SV *newbase)
490     CODE:
491         if (!SvROK(sv) || SvTYPE(SvRV(sv)) >= SVt_PVAV)
492             Perl_croak(aTHX_ "Not a SCALAR reference");
493         {
494             SV *base = FEATURE_ARYBASE_IS_ENABLED
495                         ? cop_hints_fetch_pvs(PL_curcop, "$[", 0)
496                         : 0;
497             SvGETMAGIC(newbase);
498             if (!SvOK(newbase)) SvSetMagicSV(SvRV(sv),&PL_sv_undef);
499             else 
500                 sv_setiv_mg(
501                    SvRV(sv),
502                    adjust_index(
503                       SvIV_nomg(newbase), base&&SvOK(base)?SvIV(base):0
504                    )
505                 );
506         }