| 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 | 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); |
| 169 | Perl_ck_warner_d(aTHX_ |
| 170 | packWARN(WARN_DEPRECATED), "Use of assignment to $[ is deprecated" |
| 171 | ); |
| 172 | } |
| 173 | } |
| 174 | |
| 175 | STATIC OP *ab_ck_sassign(pTHX_ OP *o) { |
| 176 | o = (*ab_old_ck_sassign)(aTHX_ o); |
| 177 | if (o->op_type == OP_SASSIGN && FEATURE_ARYBASE_IS_ENABLED) { |
| 178 | OP *right = cBINOPx(o)->op_first; |
| 179 | OP *left = right->op_sibling; |
| 180 | if (left) ab_process_assignment(left, right); |
| 181 | } |
| 182 | return o; |
| 183 | } |
| 184 | |
| 185 | STATIC OP *ab_ck_aassign(pTHX_ OP *o) { |
| 186 | o = (*ab_old_ck_aassign)(aTHX_ o); |
| 187 | if (o->op_type == OP_AASSIGN && FEATURE_ARYBASE_IS_ENABLED) { |
| 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); |
| 192 | } |
| 193 | return o; |
| 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: |
| 248 | firstp = PL_stack_base + *(PL_markstack_ptr-1)+1; |
| 249 | count = TOPMARK - *(PL_markstack_ptr-1); |
| 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; |
| 350 | default: |
| 351 | DIE(aTHX_ |
| 352 | "panic: invalid op type for arybase.xs:ab_ck_base: %d", |
| 353 | PL_op->op_type); |
| 354 | } |
| 355 | o = (*old_ck)(aTHX_ o); |
| 356 | if (!FEATURE_ARYBASE_IS_ENABLED) return o; |
| 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); |
| 400 | sv_unmagic(GvSV(gv), PERL_MAGIC_sv); /* This is *our* scalar now! */ |
| 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 |
| 408 | #define check(uc,lc,ck) \ |
| 409 | wrap_op_checker(OP_##uc, ab_ck_##ck, &ab_old_ck_##lc) |
| 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: |
| 429 | SV *ret = FEATURE_ARYBASE_IS_ENABLED |
| 430 | ? cop_hints_fetch_pvs(PL_curcop, "$[", 0) |
| 431 | : 0; |
| 432 | PPCODE: |
| 433 | if (!ret || !SvOK(ret)) mXPUSHi(0); |
| 434 | else XPUSHs(ret); |
| 435 | |
| 436 | void |
| 437 | STORE(SV *sv, IV newbase) |
| 438 | CODE: |
| 439 | PERL_UNUSED_VAR(sv); |
| 440 | if (FEATURE_ARYBASE_IS_ENABLED) { |
| 441 | SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0); |
| 442 | if (SvOK(base) ? SvIV(base) == newbase : !newbase) XSRETURN_EMPTY; |
| 443 | Perl_croak(aTHX_ "That use of $[ is unsupported"); |
| 444 | } |
| 445 | else if (newbase) |
| 446 | Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible"); |
| 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 | { |
| 458 | SV *base = FEATURE_ARYBASE_IS_ENABLED |
| 459 | ? cop_hints_fetch_pvs(PL_curcop, "$[", 0) |
| 460 | : 0; |
| 461 | SvGETMAGIC(SvRV(sv)); |
| 462 | if (!SvOK(SvRV(sv))) XSRETURN_UNDEF; |
| 463 | mXPUSHi(adjust_index_r( |
| 464 | SvIV_nomg(SvRV(sv)), base&&SvOK(base)?SvIV(base):0 |
| 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 | { |
| 474 | SV *base = FEATURE_ARYBASE_IS_ENABLED |
| 475 | ? cop_hints_fetch_pvs(PL_curcop, "$[", 0) |
| 476 | : 0; |
| 477 | SvGETMAGIC(newbase); |
| 478 | if (!SvOK(newbase)) SvSetMagicSV(SvRV(sv),&PL_sv_undef); |
| 479 | else |
| 480 | sv_setiv_mg( |
| 481 | SvRV(sv), |
| 482 | adjust_index( |
| 483 | SvIV_nomg(newbase), base&&SvOK(base)?SvIV(base):0 |
| 484 | ) |
| 485 | ); |
| 486 | } |