view release on metacpan or  search on metacpan

xs/new.xs  view on Meta::CPAN

 if (!(oi = ptable_fetch(cp_op_map, o))) {
  oi = PerlMemShared_malloc(sizeof *oi);
  ptable_map_store(cp_op_map, o, oi);
 }

 oi->old_pp = old_pp;
/* oi->next   = next;
 oi->flags  = flags;
*/
 return oi;
}

STATIC void cp_map_store(
 pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX))
{
#define cp_map_store(O, PP) cp_map_store(aPTBLMS_ (O),(PP))

#ifdef USE_ITHREADS
 MUTEX_LOCK(&cp_op_map_mutex);
#endif

 cp_map_store_locked(o, old_pp);

#ifdef USE_ITHREADS
 MUTEX_UNLOCK(&cp_op_map_mutex);
#endif
}

STATIC void cp_map_delete(pTHX_ const OP *o) {
#define cp_map_delete(O) cp_map_delete(aTHX_ (O))
#ifdef USE_ITHREADS
 MUTEX_LOCK(&cp_op_map_mutex);
#endif

 ptable_map_store(cp_op_map, o, NULL);

#ifdef USE_ITHREADS
 MUTEX_UNLOCK(&cp_op_map_mutex);
#endif
}


/* ========== ARYBASE FEATURE ========== */

#ifdef CP_ARYBASE

STATIC void set_arybase_to(pTHX_ IV base) {
#define set_arybase_to(base) set_arybase_to(aTHX_ (base))
 ENTER;
 Perl_load_module(aTHX_ 0, newSVpvs("Array::Base"), newSVnv(4/((NV)1000)),
   newSViv(base), NULL);
 Perl_load_module(aTHX_ 0, newSVpvs("String::Base"), NULL,
   newSViv(base), NULL);
 LEAVE;
}

STATIC OP *(*cp_arybase_old_ck_sassign)(pTHX_ OP *) = 0;
STATIC OP *(*cp_arybase_old_ck_aassign)(pTHX_ OP *) = 0;

#define arybase     "Classic_Perl__$["
#define arybase_len  (sizeof(arybase)-1)

STATIC bool cp_op_is_dollar_bracket(pTHX_ OP *o) {
#define cp_op_is_dollar_bracket(o) cp_op_is_dollar_bracket(aTHX_ (o))
 OP *c;
 return o->op_type == OP_RV2SV && (o->op_flags & OPf_KIDS)
  && (c = cUNOPx(o)->op_first)
  && c->op_type == OP_GV
  && strEQ(GvNAME(cGVOPx_gv(c)), "[");
}

STATIC void cp_neuter_dollar_bracket(pTHX_ OP *o) {
#define cp_neuter_dollar_bracket(o) cp_neuter_dollar_bracket(aTHX_ (o))
 OP *oldc, *newc;
 /*
  * Must replace the core's $[ with something that can accept assignment
  * of non-zero value and can be local()ised.  Simplest thing is a
  * different global variable.
  */
 oldc = cUNOPx(o)->op_first;
 newc = newGVOP(OP_GV, 0,
   gv_fetchpvs("Classic::Perl::[", GV_ADDMULTI, SVt_PVGV));
 cUNOPx(o)->op_first = newc;
 op_free(oldc);
}

STATIC void cp_arybase_process_assignment(pTHX_ SV *hsv, OP *left, OP *right) {
#define cp_arybase_process_assignment(h, l, r) \
    cp_arybase_process_assignment(aTHX_ (h), (l), (r))
 if (cp_op_is_dollar_bracket(left) && right->op_type == OP_CONST) {
  IV base = SvIV(cSVOPx_sv(right));
  sv_setiv_mg(hsv, base);
  set_arybase_to(base);
  cp_neuter_dollar_bracket(left);
 }
}

STATIC OP *cp_arybase_ck_sassign(pTHX_ OP *o) {
 SV *hintsv = cp_hint(arybase, arybase_len);
 o = (*cp_arybase_old_ck_sassign)(aTHX_ o);
 if (hintsv && SvOK(hintsv)) {
  OP *right = cBINOPx(o)->op_first;
  OP *left = OpSIBLING(right);
  if (left) cp_arybase_process_assignment(hintsv, left, right);
 }
 return o;
}

STATIC OP *cp_arybase_ck_aassign(pTHX_ OP *o) {
 SV *hintsv = cp_hint(arybase, arybase_len);
 o = (*cp_arybase_old_ck_aassign)(aTHX_ o);
 if (hintsv && SvOK(hintsv)) {
  OP *right = cBINOPx(o)->op_first;
  OP *left = OpSIBLING(cBINOPx(OpSIBLING(right))->op_first);
  right = OpSIBLING(cBINOPx(right)->op_first);
  cp_arybase_process_assignment(hintsv, left, right);
 }
 return o;
}

#endif /* CP_ARYBASE */

/* ========== SPLIT FEATURE ========== */

/* How this works

Way down at the bottom of this file,  we override the PL_check[OP_SPLIT]
function (assigning to it after saving the old value). The override calls
the original function and then,  if the pragma is in scope and the  split
does not have a gv, we replace the op’s pp function with our own wrapper
around pp_split.

To avoid the void warning, we have to give the op a gv. The only problem is
that in the  PL_check  function we don’t yet know what the context will be.
We don’t want to split to @_ in list context, so we delete the @_ temporar-
ily in our pp_ function. It has to be temporary, as split could be the last