view release on metacpan or  search on metacpan

xs/new.xs  view on Meta::CPAN

                           Array::Base fails assertions on newer perls. */
#endif
#if CP_HAS_PERL(5, 11, 0)
# define CP_SPLIT
#endif
#define CP_MULTILINE

#ifndef OpSIBLING
# define OpSIBLING(o) (o)->op_sibling
#endif

STATIC SV * cp_hint(pTHX_ char *key, U32 keylen) {
#define cp_hint(a,b) cp_hint(aTHX_ (a),(b))
 SV **val
  = hv_fetch(GvHV(PL_hintgv), key, keylen, 0);
 if (!val)
  return 0;
 return *val;
}

/* ... op => info map ...................................................... */

typedef struct {
 OP *(*old_pp)(pTHX);
} cp_op_info;

#define PTABLE_NAME        ptable_map
#define PTABLE_VAL_FREE(V) PerlMemShared_free(V)

#include "ptable.h"

/* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
#define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))

STATIC ptable *cp_op_map = NULL;

#ifdef USE_ITHREADS
STATIC perl_mutex cp_op_map_mutex;
#endif

STATIC const cp_op_info *cp_map_fetch(const OP *o, cp_op_info *oi) {
 const cp_op_info *val;

#ifdef USE_ITHREADS
 MUTEX_LOCK(&cp_op_map_mutex);
#endif

 val = ptable_fetch(cp_op_map, o);
 if (val) {
  *oi = *val;
  val = oi;
 }

#ifdef USE_ITHREADS
 MUTEX_UNLOCK(&cp_op_map_mutex);
#endif

 return val;
}

STATIC const cp_op_info *cp_map_store_locked(
 pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX)
) {
#define cp_map_store_locked(O, PP) \
  cp_map_store_locked(aPTBLMS_ (O), (PP))
 cp_op_info *oi;

 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));