1/* Copyright (c) 1997-2021 2 Ewgenij Gawrilow, Michael Joswig, and the polymake team 3 Technische Universität Berlin, Germany 4 https://polymake.org 5 6 This program is free software; you can redistribute it and/or modify it 7 under the terms of the GNU General Public License as published by the 8 Free Software Foundation; either version 2, or (at your option) any 9 later version: http://www.gnu.org/licenses/gpl.txt. 10 11 This program is distributed in the hope that it will be useful, 12 but WITHOUT ANY WARRANTY; without even the implied warranty of 13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 GNU General Public License for more details. 15-------------------------------------------------------------------------------- 16*/ 17 18#include "polymake/perl/Ext.h" 19 20/******************************************************************************************************/ 21/* references as hash keys */ 22 23namespace pm { namespace perl { namespace glue { 24 25namespace { 26 27HV* my_pkg; 28AV* allowed_pkgs; 29 30Perl_check_t def_ck_PUSH; 31Perl_ppaddr_t def_pp_CONST, def_pp_HELEM, def_pp_HSLICE, def_pp_EXISTS, def_pp_DELETE, def_pp_EACH, def_pp_KEYS, 32 def_pp_RV2HV, def_pp_PADHV, def_pp_ANONHASH; 33 34#if PerlVersion >= 5180 35Perl_ppaddr_t def_pp_PADRANGE; 36#endif 37#if PerlVersion >= 5220 38Perl_check_t def_ck_HELEM, def_ck_EXISTS, def_ck_DELETE; 39#endif 40 41struct tmp_keysv { 42 HEK hek; 43 size_t key_tail = 0; // the last byte is the terminating 0, the first byte of the key resides in hek. 44 XPVUV xpv; 45 SV sv; 46 47 SV* set(SV* keysv); 48 U32 hash() const { return HEK_HASH(&hek); } 49}; 50 51union key_or_ptr { 52 SV* ptr; 53 unsigned long keyl; 54 char keyp[sizeof(SV*)]; 55}; 56 57#if PerlVersion < 5180 58# define PmFlagsForHashKey (SVf_FAKE | SVf_READONLY) 59#else 60# define PmFlagsForHashKey SVf_IsCOW 61#endif 62 63SV* tmp_keysv::set(SV* keysv) 64{ 65 HEK* hekp = &hek; 66 key_or_ptr obj; 67 obj.ptr = SvRV(keysv); 68#if PerlVersion < 5180 69 if (SvAMAGIC(keysv)) obj.keyl |= 1; 70#endif 71 Copy(obj.keyp, HEK_KEY(hekp), sizeof(SV*), char); 72 HEK_LEN(hekp) = sizeof(SV*); 73 HEK_HASH(hekp) = U32(obj.keyl >> 4); // hash value 74 HEK_FLAGS(hekp) = HVhek_UNSHARED; 75 sv.sv_any = &xpv; 76 sv.sv_refcnt = 1; 77 sv.sv_flags = SVt_PVIV | SVf_IVisUV | SVf_POK | SVp_POK | PmFlagsForHashKey; 78 SvPV_set(&sv, HEK_KEY(hekp)); 79 SvCUR_set(&sv, sizeof(SV*)); 80 SvLEN_set(&sv, 0); 81 return &sv; 82} 83 84#define MarkAsRefHash(hv) SvSTASH(hv)=my_pkg 85#define MarkAsNormalHash(hv) SvSTASH(hv)=Nullhv 86 87OP* ErrNoRef(pTHX_ SV* key) 88{ 89 if (SvOK(key)) { 90 STRLEN kl; const char* k=SvPV(key,kl); 91 DIE(aTHX_ "Hash key '%*.s' where reference expected", (int)kl, k); 92 } 93 DIE(aTHX_ "Hash key UNDEF where reference expected"); 94} 95 96static const char err_ref[]="Reference as a key in a normal hash"; 97 98bool ref_key_allowed(HV* stash) 99{ 100 if (AvFILLp(allowed_pkgs) >=0 ) { 101 for (SV **ap=AvARRAY(allowed_pkgs), **end=ap+AvFILLp(allowed_pkgs); ap<=end; ++ap) 102 if (SvRV(*ap)==(SV*)stash) return true; 103 } 104 return false; 105} 106 107bool ref_key_allowed(pTHX_ HV* hv, HV* stash) 108{ 109 return stash==my_pkg || 110 (!stash 111 ? !HvFILL(hv) && !SvRMAGICAL(hv) && (MarkAsRefHash(hv), true) 112 : ref_key_allowed(stash)); 113} 114 115MAGIC* hash_is_cpp_class(HV* hv, HV* stash) 116{ 117 return (stash && SvMAGICAL(hv)) ? get_cpp_magic((SV*)(hv)) : nullptr; 118} 119 120MAGIC* hash_is_monitored_class(HV* hv, HV* stash) 121{ 122 return (!stash && SvSMAGICAL(hv)) ? get_monitored_magic((SV*)(hv)) : nullptr; 123} 124 125struct local_hash_ref_elem { 126 HV *hv; 127 SV *keyref; 128}; 129 130void* store_hash_ref_elem(pTHX_ HV* hv, SV* keyref) 131{ 132 local_hash_ref_elem* le; 133 Newx(le, 1, local_hash_ref_elem); 134 le->hv=(HV*)SvREFCNT_inc_simple_NN(hv); 135 le->keyref=SvREFCNT_inc_simple_NN(keyref); 136 return le; 137} 138 139void delete_hash_elem(pTHX_ void* p) 140{ 141 local_hash_ref_elem* le=(local_hash_ref_elem*)p; 142 tmp_keysv tmp_key; 143 HV* hv=le->hv; 144 SV* keyref=le->keyref; 145 SV* keysv=tmp_key.set(keyref); 146 (void)hv_delete_ent(hv, keysv, G_DISCARD, tmp_key.hash()); 147 SvREFCNT_dec(hv); 148 SvREFCNT_dec(keyref); 149 Safefree(p); 150} 151 152OP* intercept_pp_helem(pTHX) 153{ 154 dSP; 155 SV* keysv = TOPs; 156 HV* hv = (HV*)TOPm1s; 157 HV* stash = SvSTASH(hv); 158 tmp_keysv tmp_key; 159 if (MAGIC* mg = hash_is_cpp_class(hv, stash)) { 160 return cpp_helem(aTHX_ hv, mg); 161 } 162 if (MAGIC* mg = hash_is_monitored_class(hv, stash)) { 163 OP* next = Perl_pp_helem(aTHX); 164 if (!(PL_op->op_private & OPpLVAL_INTRO) && (PL_op->op_flags & OPf_MOD || LVRET)) { 165 if ((PL_op->op_private & OPpLVAL_DEFER) || 166 next != nullptr && (next->op_type == OP_ORASSIGN || 167 next->op_type == OP_DORASSIGN || 168 next->op_type == OP_ANDASSIGN)) { 169 SPAGAIN; 170 SV* elem = TOPs; 171 mg->mg_virtual->svt_copy(aTHX_ (SV*)hv, mg, elem, nullptr, 0); 172 } else { 173 mg->mg_virtual->svt_set(aTHX_ (SV*)hv, mg); 174 } 175 } 176 return next; 177 } 178 if (SvROK(keysv)) { 179 if (!ref_key_allowed(aTHX_ hv, stash)) 180 DIE(aTHX_ err_ref); 181 if ((PL_op->op_private & (OPpLVAL_INTRO | OPpLVAL_DEFER)) == OPpLVAL_INTRO && 182 (PL_op->op_flags & OPf_MOD || LVRET)) { 183 SV* keyref = keysv; 184 keysv = tmp_key.set(keysv); 185 const U32 hash = tmp_key.hash(); 186 const I32 existed = hv_exists_ent(hv, keysv, hash); 187 HE* he = hv_fetch_ent(hv, keysv, TRUE, hash); 188 SV* elem_sv = HeVAL(he); 189 if (existed) 190 ops::localize_scalar(aTHX_ elem_sv); 191 else 192 save_destructor_x(&delete_hash_elem, store_hash_ref_elem(aTHX_ hv, keyref)); 193 (void)POPs; 194 SETs(elem_sv); 195 RETURN; 196 } 197 SETs(tmp_key.set(keysv)); 198 } else if (stash == my_pkg) { 199 if (HvFILL(hv)) return ErrNoRef(aTHX_ keysv); 200 MarkAsNormalHash(hv); 201 } 202 return Perl_pp_helem(aTHX); 203} 204 205OP* intercept_pp_hslice(pTHX) 206{ 207 dSP; 208 HV* hv=(HV*)POPs; 209 HV* stash=SvSTASH(hv); 210 SV** firstkey=PL_stack_base+TOPMARK+1; 211 if (firstkey <= SP) { 212 if (MAGIC* mg=hash_is_cpp_class(hv, stash)) { 213 PUTBACK; 214 return cpp_hslice(aTHX_ hv, mg); 215 } 216 if (SvROK(*firstkey)) { 217 if (ref_key_allowed(aTHX_ hv, stash)) { 218 dMARK; dORIGMARK; 219 tmp_keysv tmp_key; 220 I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); 221 I32 localizing = lval && (PL_op->op_private & OPpLVAL_INTRO); 222 I32 gimme=GIMME_V; 223 224 while (++MARK <= SP) { 225 SV *keysv=*MARK, *keyref=keysv; 226 I32 existed=FALSE; 227 if (!SvROK(keysv)) return ErrNoRef(aTHX_ keysv); 228 keysv=tmp_key.set(keysv); 229 U32 hash=tmp_key.hash(); 230 if (localizing) existed=hv_exists_ent(hv, keysv, hash); 231 HE* he=hv_fetch_ent(hv, keysv, lval, hash); 232 *MARK=he ? HeVAL(he) : &PL_sv_undef; 233 if (localizing) { 234 if (existed) 235 ops::localize_scalar(aTHX_ *MARK); 236 else 237 save_destructor_x(&delete_hash_elem, store_hash_ref_elem(aTHX_ hv, keyref)); 238 } 239 } 240 241 if (gimme != G_ARRAY) { 242 MARK = ORIGMARK; 243 *++MARK = *SP; 244 SP = MARK; 245 } 246 RETURN; 247 248 } else { 249 DIE(aTHX_ err_ref); 250 } 251 } 252 else if (stash==my_pkg) { 253 if (HvFILL(hv)) return ErrNoRef(aTHX_ *firstkey); 254 MarkAsNormalHash(hv); 255 } 256 return Perl_pp_hslice(aTHX); 257 } 258 RETURN; 259} 260 261OP* intercept_pp_exists(pTHX) 262{ 263 if (!(PL_op->op_private & OPpEXISTS_SUB)) { 264 dSP; 265 SV* keysv=TOPs; 266 HV* hv=(HV*)TOPm1s; 267 HV* stash=SvSTASH(hv); 268 if (MAGIC *mg=hash_is_cpp_class(hv, stash)) 269 return cpp_exists(aTHX_ hv, mg); 270 if (SvROK(keysv)) { 271 tmp_keysv tmp_key; 272 (void)POPs; (void)POPs; 273 if (stash != my_pkg && !(stash && ref_key_allowed(stash))) 274 RETPUSHNO; 275 keysv=tmp_key.set(keysv); 276 if (hv_exists_ent(hv, keysv, tmp_key.hash())) 277 RETPUSHYES; 278 else 279 RETPUSHNO; 280 } else if (stash == my_pkg) { 281 (void)POPs; (void)POPs; 282 RETPUSHNO; 283 } 284 } 285 return Perl_pp_exists(aTHX); 286} 287 288bool delete_special_cases(pTHX_ HV* hv, HV* stash, OP*& ret) 289{ 290 if (SvTYPE(hv) != SVt_PVHV) { 291 ret = Perl_pp_delete(aTHX); 292 return true; 293 } 294 if (MAGIC* mg = hash_is_monitored_class(hv, stash)) { 295#if PerlVersion < 5180 296 // there was an awful bug in implementation of delete local fixed in perl 5.18 297 SvRMAGICAL_off(hv); 298#endif 299 const auto had_keys = HvKEYS(hv); 300 ret = Perl_pp_delete(aTHX); 301#if PerlVersion < 5180 302 SvRMAGICAL_on(hv); 303#endif 304 if (!(PL_op->op_private & OPpLVAL_INTRO) && HvKEYS(hv) < had_keys) 305 mg->mg_virtual->svt_set(aTHX_ (SV*)hv, mg); 306 return true; 307 } 308 return false; 309} 310 311OP* intercept_pp_delete(pTHX) 312{ 313 dSP; 314 tmp_keysv tmp_key; 315 OP* ret; 316 317 if (PL_op->op_private & OPpSLICE) { 318 HV* hv = (HV*)POPs; 319 HV* stash = SvSTASH(hv); 320 if (MAGIC* mg = hash_is_cpp_class(hv, stash)) { 321 PUTBACK; 322 return cpp_delete_hslice(aTHX_ hv, mg); 323 } 324 if (delete_special_cases(aTHX_ hv, stash, ret)) { 325 return ret; 326 } 327 SV** firstkey = PL_stack_base+TOPMARK+1; 328 if (firstkey <= SP) { 329 if (SvROK(*firstkey)) { 330 if (ref_key_allowed(aTHX_ hv, stash)) { 331 dMARK; dORIGMARK; 332 I32 gimme = GIMME_V; 333 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0; 334 335 while (++MARK <= SP) { 336 SV* keysv = *MARK; 337 if (!SvROK(keysv)) 338 return ErrNoRef(aTHX_ keysv); 339 keysv = tmp_key.set(keysv); 340 SV* sv = hv_delete_ent(hv, keysv, discard, tmp_key.hash()); 341 *MARK = sv ? sv : &PL_sv_undef; 342 } 343 344 if (discard) 345 SP = ORIGMARK; 346 else if (gimme == G_SCALAR) { 347 MARK = ORIGMARK; 348 *++MARK = *SP; 349 SP = MARK; 350 } 351 RETURN; 352 } else { 353 DIE(aTHX_ err_ref); 354 } 355 } else if (stash == my_pkg) { 356 if (HvFILL(hv)) 357 return ErrNoRef(aTHX_ *firstkey); 358 MarkAsNormalHash(hv); 359 } 360 } 361 } else { 362 HV* hv = (HV*)TOPm1s; 363 HV* stash = SvSTASH(hv); 364 if (MAGIC* mg = hash_is_cpp_class(hv, stash)) { 365 return cpp_delete_helem(aTHX_ hv, mg); 366 } 367 if (delete_special_cases(aTHX_ hv, stash, ret)) { 368 return ret; 369 } 370 SV* keysv = TOPs; 371 if (SvROK(keysv)) { 372 if (ref_key_allowed(aTHX_ hv, stash)) { 373 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0; 374 (void)POPs; (void)POPs; 375 keysv = tmp_key.set(keysv); 376 SV* sv = hv_delete_ent(hv, keysv, discard, tmp_key.hash()); 377 if (!discard) { 378 if (!sv) sv = &PL_sv_undef; 379 PUSHs(sv); 380 } 381 RETURN; 382 } else { 383 DIE(aTHX_ err_ref); 384 } 385 } else if (stash == my_pkg) { 386 if (HvFILL(hv)) 387 return ErrNoRef(aTHX_ keysv); 388 MarkAsNormalHash(hv); 389 } 390 } 391 return Perl_pp_delete(aTHX); 392} 393 394void key2ref(pTHX_ SV* keysv) 395{ 396 U32 flags=PmFlagsForHashKey | SVf_POK | SVp_POK | SVf_ROK; 397 key_or_ptr obj; 398 obj.ptr=*(SV**)SvPVX(keysv); 399#if PerlVersion < 5180 400 if (obj.keyl & 1) { 401 obj.keyl ^= 1; 402 flags |= SVf_AMAGIC; 403 } 404#endif 405 if ((SvFLAGS(keysv) & PmFlagsForHashKey) == PmFlagsForHashKey) 406 Perl_unshare_hek(aTHX_ SvSHARED_HEK_FROM_PV(SvPVX_const(keysv))); 407 SvFLAGS(keysv) ^= flags; 408 SvRV(keysv)=obj.ptr; 409#ifdef DEBUG_LEAKING_SCALARS 410 if (obj.ptr->sv_flags == SVTYPEMASK || obj.ptr->sv_refcnt == 0) 411 Perl_croak(aTHX_ "dead key %p", obj.ptr); 412#endif 413 SvREFCNT_inc_simple_void_NN(obj.ptr); 414} 415 416OP* intercept_pp_each(pTHX) 417{ 418 dSP; 419 HV* hv = (HV*)TOPs; 420 HV* stash = SvSTASH(hv); 421 if (stash == my_pkg || (stash && ref_key_allowed(stash))) { 422 SSize_t sp_dist = SP - PL_stack_base; 423 OP* ret = Perl_pp_each(aTHX); 424 sp = PL_stack_base + sp_dist; 425 if (PL_stack_sp >= sp) key2ref(aTHX_ *sp); 426 return ret; 427 } 428 return Perl_pp_each(aTHX); 429} 430 431OP* intercept_pp_keys(pTHX) 432{ 433 dSP; 434 HV* hv = (HV*)TOPs; 435 HV* stash = SvSTASH(hv); 436 MAGIC* mg; 437 I32 gimme = GIMME_V; 438 if (gimme == G_ARRAY && (stash==my_pkg || (stash && ref_key_allowed(stash)))) { 439 SSize_t sp_dist = SP - PL_stack_base; 440 OP* ret = def_pp_KEYS(aTHX); 441 SV** last = PL_stack_sp; 442 for (sp = PL_stack_base + sp_dist; sp <= last; ++sp) 443 key2ref(aTHX_ *sp); 444 return ret; 445 } 446 if (gimme == G_SCALAR && (mg = hash_is_cpp_class(hv, stash))) 447 return cpp_keycnt(aTHX_ hv, mg); 448 return def_pp_KEYS(aTHX); 449} 450 451// aassign isn't intercepted directly, since it is used very often and not only with hashes. 452// Instead, this routine is called from rv2hv and padhv when necessary 453OP* ref_assign(pTHX) 454{ 455 dSP; 456 I32 gimme = GIMME_V; 457 HV* hv = (HV*)POPs; 458 HV* stash = SvSTASH(hv); 459 I32 lastR = TOPMARK, firstR = PL_markstack_ptr[-1]+1; 460 const bool assign_other = SP - PL_stack_base != lastR; 461 IV n_keys = 0; 462 463 if (assign_other) { 464 SV** lhs = PL_stack_base+lastR+1; 465 do { 466 I32 type = SvTYPE(*lhs); 467 if (type == SVt_PVAV || type == SVt_PVHV) { 468 firstR = lastR; 469 break; 470 } 471 ++firstR; 472 } while (++lhs <= SP); 473 } 474 if (MAGIC* mg = hash_is_cpp_class(hv, stash)) { 475 PUTBACK; 476 n_keys = cpp_hassign(aTHX_ hv, mg, &firstR, lastR, !assign_other); 477 SPAGAIN; 478 479 } else if (firstR < lastR && SvROK(PL_stack_base[firstR])) { 480 if (!ref_key_allowed(aTHX_ hv, stash)) 481 DIE(aTHX_ err_ref); 482 483 // the assignment loop is borrowed from the appropriate branch in pp_aassign 484 hv_clear(hv); 485 do { 486 tmp_keysv tmp_key; 487 SV* keysv = PL_stack_base[firstR++]; 488 if (!keysv || !SvROK(keysv)) 489 return ErrNoRef(aTHX_ keysv); 490 keysv = tmp_key.set(keysv); 491 SV* tmp_val = PL_stack_base[firstR] ? newSVsv(PL_stack_base[firstR]) : newSV_type(SVt_NULL); // value 492 PL_stack_base[firstR++] = tmp_val; 493 (void)hv_store_ent(hv, keysv, tmp_val, tmp_key.hash()); 494 } while (firstR < lastR); 495 496 if (firstR == lastR) { 497 SV* keysv = PL_stack_base[firstR]; 498 if (!keysv || !SvROK(keysv)) 499 return ErrNoRef(aTHX_ keysv); 500 if (SvSTASH(SvRV(keysv)) == my_pkg) 501 DIE(aTHX_ "RefHash object assignment in list context"); 502 else 503 DIE(aTHX_ "Key without value in hash assignment"); 504 } 505 n_keys = HvFILL(hv); 506 507 } else { 508 if (stash==my_pkg) MarkAsNormalHash(hv); 509 return Perl_pp_aassign(aTHX); 510 } 511 512 if (assign_other) { 513 PUTBACK; 514 OP* ret = Perl_pp_aassign(aTHX); 515 if (gimme == G_ARRAY) { 516 SP = PL_stack_base + lastR; 517 PUTBACK; 518 } 519 return ret; 520 } 521 522 PL_markstack_ptr-=2; 523 if (gimme == G_VOID) 524 SP = PL_stack_base+firstR-1; 525 else if (gimme == G_ARRAY) 526 SP = PL_stack_base+lastR; 527 else { 528 dTARGET; 529 SP = PL_stack_base+firstR; 530 SETi(n_keys*2); 531 } 532 RETURN; 533} 534 535OP* pp_pushhv(pTHX) 536{ 537 dSP; dMARK; dORIGMARK; 538 HV* hv=(HV*)*++MARK; 539 HV* stash=SvSTASH(hv); 540 541 if (MARK < SP) { 542 if (SvROK(MARK[1])) { 543 if (ref_key_allowed(aTHX_ hv, stash)) { 544 tmp_keysv tmp_key; 545 do { 546 SV* keysv=*++MARK; 547 if (!SvROK(keysv)) return ErrNoRef(aTHX_ keysv); 548 keysv=tmp_key.set(keysv); 549 SV* value=*++MARK; 550 SV* tmp_val = value ? newSVsv(value) : newSV_type(SVt_NULL); // copy of the value 551 (void)hv_store_ent(hv, keysv, tmp_val, tmp_key.hash()); 552 } while (MARK < SP); 553 } else { 554 DIE(aTHX_ err_ref); 555 } 556 } else { 557 if (stash==my_pkg) { 558 if (HvFILL(hv)) return ErrNoRef(aTHX_ MARK[1]); 559 MarkAsNormalHash(hv); 560 } 561 do { 562 SV* keysv=*++MARK; 563 if (SvROK(keysv)) 564 DIE(aTHX_ err_ref); 565 SV* value=*++MARK; 566 SV* tmp_val = value ? newSVsv(value) : newSV_type(SVt_NULL); // copy of the value 567 (void)hv_store_ent(hv, keysv, tmp_val, SvSHARED_HASH(keysv)); 568 } while (MARK < SP); 569 } 570 } 571 SP=ORIGMARK; 572 RETURN; 573} 574 575OP* pp_rv2hv_ref_retrieve(pTHX) 576{ 577 dSP; 578 SSize_t sp_dist = SP - PL_stack_base; 579 OP* ret = def_pp_RV2HV(aTHX); 580 SV** last = PL_stack_sp; 581 for (SP = PL_stack_base + sp_dist; SP < last; SP += 2) 582 key2ref(aTHX_ *SP); 583 return ret; 584} 585 586OP* pp_padhv_ref_retrieve(pTHX) 587{ 588 dSP; 589 SSize_t sp_dist = SP - PL_stack_base+1; 590 OP* ret = Perl_pp_padhv(aTHX); 591 SV** last = PL_stack_sp; 592 for (SP = PL_stack_base + sp_dist; SP < last; SP += 2) 593 key2ref(aTHX_ *SP); 594 return ret; 595} 596 597OP* intercept_pp_rv2hv(pTHX) 598{ 599 dSP; 600 SV* hv = TOPs; 601 HV* stash; 602 if (PL_op->op_flags & OPf_REF) { 603 if (PL_op->op_next->op_type == OP_AASSIGN) { 604 PL_op = def_pp_RV2HV(aTHX); 605 return ref_assign(aTHX); 606 } 607 if (SvROK(hv)) { 608 hv = SvRV(hv); 609 stash = SvSTASH(hv); 610 MAGIC* mg; 611 if ((SvTYPE(hv) == SVt_PVHV || SvTYPE(hv) == SVt_PVAV) && (mg = hash_is_cpp_class((HV*)hv, stash)) && 612 cpp_has_assoc_methods(mg)) { 613 // escape the type check in rv2hv=rv2av in perl 5.10 614 SETs(hv); 615 RETURN; 616 } 617 } 618 } else if (GIMME_V == G_ARRAY) { 619 if (SvROK(hv)) { // the easiest and most often case 620 stash = SvSTASH(SvRV(hv)); 621 if (stash == my_pkg || (stash && ref_key_allowed(stash))) 622 return pp_rv2hv_ref_retrieve(aTHX); 623 else 624 return def_pp_RV2HV(aTHX); 625 } 626 SAVEI8(PL_op->op_flags); // just for the case the op dies 627 PL_op->op_flags ^= OPf_REF; 628 def_pp_RV2HV(aTHX); // get the hash 629 PL_op->op_flags ^= OPf_REF; 630 hv = TOPs; 631 stash = SvSTASH(hv); 632 if (stash == my_pkg || (stash && ref_key_allowed(stash))) 633 return pp_rv2hv_ref_retrieve(aTHX); 634 } 635 return def_pp_RV2HV(aTHX); 636} 637 638OP* intercept_pp_padhv(pTHX) 639{ 640 if (PL_op->op_flags & OPf_REF) { 641 if (PL_op->op_next->op_type == OP_AASSIGN) { 642 PL_op=Perl_pp_padhv(aTHX); 643 return ref_assign(aTHX); 644 } 645 } else if (GIMME_V == G_ARRAY) { 646 dTARGET; 647 HV* hv=(HV*)TARG; 648 HV* stash=SvSTASH(hv); 649 if (stash==my_pkg || (stash && ref_key_allowed(stash))) { 650 return pp_padhv_ref_retrieve(aTHX); 651 } 652 } 653 return Perl_pp_padhv(aTHX); 654} 655 656#if PerlVersion >= 5180 657OP* intercept_pp_padrange_known(pTHX) 658{ 659 PL_op=Perl_pp_padrange(aTHX); 660 return ref_assign(aTHX); 661} 662 663OP* intercept_pp_padrange_unknown(pTHX) 664{ 665 OP* o=PL_op; 666 OP* sib=OpSIBLING(o); 667 OP* next=Perl_pp_padrange(aTHX); 668 if (next->op_type == OP_AASSIGN) { 669 while (sib) { 670 if (sib->op_type == OP_PADHV && (sib->op_flags & OPf_REF)) { 671 o->op_ppaddr=&intercept_pp_padrange_known; 672 PL_op=next; 673 return ref_assign(aTHX); 674 } 675 sib=OpSIBLING(sib); 676 } 677 } 678 o->op_ppaddr=def_pp_PADRANGE; 679 return next; 680} 681#endif 682 683OP* pp_ref_anonhash(pTHX) 684{ 685 dSP; dMARK; dORIGMARK; 686 HV* hv = newHV(); 687 tmp_keysv tmp_key; 688 MarkAsRefHash(hv); 689 while (++MARK < SP) { 690 SV* keysv = *MARK; 691 if (!SvROK(keysv)) return ErrNoRef(aTHX_ keysv); 692 keysv = tmp_key.set(keysv); 693 SV* val = MARK < SP ? newSVsv(*++MARK) : newSV_type(SVt_NULL); 694 (void)hv_store_ent(hv, keysv, val, tmp_key.hash()); 695 } 696 SP = ORIGMARK; 697 XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL) 698 ? newRV_noinc((SV*)hv) : (SV*)hv)); 699 RETURN; 700} 701 702OP* intercept_pp_anonhash(pTHX) 703{ 704 dSP; 705 SV **firstkey=PL_stack_base+TOPMARK+1; 706 if (firstkey<SP && SvROK(*firstkey)) 707 return pp_ref_anonhash(aTHX); 708 return Perl_pp_anonhash(aTHX); 709} 710 711OP* check_pushhv(pTHX_ OP *o) 712{ 713 if (o->op_flags & OPf_KIDS) { 714 OP* kid = cLISTOPo->op_first; 715 if (kid->op_type == OP_PUSHMARK || 716 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) 717 kid = OpSIBLING(kid); 718 if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV) { 719 int arg_cnt = 2; 720 op_lvalue(kid, o->op_type); 721 while ((kid=OpSIBLING(kid))) { 722 if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV) { 723 Perl_list(aTHX_ kid); 724 } else { 725 Perl_yyerror(aTHX_ Perl_form(aTHX_ "Type of arg %d to push must be hash (not %s)", arg_cnt, OP_DESC(kid))); 726 } 727 ++arg_cnt; 728 } 729 o->op_ppaddr = &pp_pushhv; 730 return o; 731 } 732 } 733 return Perl_ck_fun(aTHX_ o); 734} 735 736#if PerlVersion >= 5220 737// The following senseless routines have a sole purpose: 738// to prevent the operations HELEM, EXISTS, and DELETE from being lumped together with MULTIDEREF. 739// The concrete manipulations have been deduced from studying the source code of S_maybe_multideref, 740// they might need to be adapted in the future versions. 741 742OP* intercept_ck_helem(pTHX_ OP *o) 743{ 744 // currently it's enough just to install a non-standard check hook 745 return def_ck_HELEM(aTHX_ o); 746} 747 748// For EXISTS and DELETE, it's enough to mark the operation delivering the key with a flag OPf_REF; 749// this flag does not influence the operation itself but, weirdly enough, is respected by S_maybe_multideref. 750void protect_key_operand(pTHX_ OP* o) 751{ 752 o=cUNOPo->op_first; // null = former HELEM or HSLICE 753 assert(o->op_type == OP_NULL); 754 if (o->op_targ != OP_HELEM) return; 755 756 o=cBINOPo->op_last; // key source 757 switch (o->op_type) 758 { 759 case OP_PADSV: 760 o->op_flags |= OPf_REF; 761 break; 762 case OP_RV2SV: 763 if (cUNOPo->op_first->op_type == OP_GV) 764 o->op_flags |= OPf_REF; 765 break; 766 } 767} 768 769OP* intercept_ck_exists(pTHX_ OP *o) 770{ 771 o=def_ck_EXISTS(aTHX_ o); 772 protect_key_operand(aTHX_ o); 773 return o; 774} 775 776OP* intercept_ck_delete(pTHX_ OP *o) 777{ 778 o=def_ck_DELETE(aTHX_ o); 779 protect_key_operand(aTHX_ o); 780 return o; 781} 782 783#endif 784 785OP* intercept_pp_const(pTHX) 786{ 787 SV* sv = cSVOP_sv; 788 if ((PL_op->op_private & OPpCONST_BARE) && SvTYPE(sv) == SVt_PV) 789 SvIsUV_on(sv); 790 PL_op->op_ppaddr = &Perl_pp_const; 791 return Perl_pp_const(aTHX); 792} 793 794void catch_ptrs(pTHX_ SV *dummy) 795{ 796 PL_ppaddr[OP_CONST] = &intercept_pp_const; 797 PL_ppaddr[OP_HELEM] = &intercept_pp_helem; 798 PL_ppaddr[OP_HSLICE] = &intercept_pp_hslice; 799 PL_ppaddr[OP_EXISTS] = &intercept_pp_exists; 800 PL_ppaddr[OP_DELETE] = &intercept_pp_delete; 801 PL_ppaddr[OP_EACH] = &intercept_pp_each; 802 PL_ppaddr[OP_KEYS] = &intercept_pp_keys; 803 PL_ppaddr[OP_RV2HV] = &intercept_pp_rv2hv; 804 PL_ppaddr[OP_PADHV] = &intercept_pp_padhv; 805#if PerlVersion >= 5180 806 PL_ppaddr[OP_PADRANGE] = &intercept_pp_padrange_unknown; 807#endif 808 PL_ppaddr[OP_ANONHASH] = &intercept_pp_anonhash; 809 PL_check[OP_PUSH] = &check_pushhv; 810#if PerlVersion >= 5220 811 PL_check[OP_HELEM] = &intercept_ck_helem; 812 PL_check[OP_EXISTS] = &intercept_ck_exists; 813 PL_check[OP_DELETE] = &intercept_ck_delete; 814#endif 815} 816 817void reset_ptrs(pTHX_ SV *dummy) 818{ 819 PL_ppaddr[OP_CONST] = def_pp_CONST; 820 PL_ppaddr[OP_HELEM] = def_pp_HELEM; 821 PL_ppaddr[OP_HSLICE] = def_pp_HSLICE; 822 PL_ppaddr[OP_EXISTS] = def_pp_EXISTS; 823 PL_ppaddr[OP_DELETE] = def_pp_DELETE; 824 PL_ppaddr[OP_EACH] = def_pp_EACH; 825 PL_ppaddr[OP_KEYS] = def_pp_KEYS; 826 PL_ppaddr[OP_RV2HV] = def_pp_RV2HV; 827 PL_ppaddr[OP_PADHV] = def_pp_PADHV; 828#if PerlVersion >= 5180 829 PL_ppaddr[OP_PADRANGE] = def_pp_PADRANGE; 830#endif 831 PL_ppaddr[OP_ANONHASH] = def_pp_ANONHASH; 832 PL_check[OP_PUSH] = def_ck_PUSH; 833#if PerlVersion >= 5220 834 PL_check[OP_HELEM] = def_ck_HELEM; 835 PL_check[OP_EXISTS] = def_ck_EXISTS; 836 PL_check[OP_DELETE] = def_ck_DELETE; 837#endif 838} 839 840} 841 842HE* refhash_fetch_ent(pTHX_ HV* hv, SV* keysv, I32 lval) 843{ 844 tmp_keysv tmp_key; 845 HV* stash=SvSTASH(hv); 846 assert(SvROK(keysv)); 847 if (!ref_key_allowed(aTHX_ hv, stash)) 848 Perl_croak(aTHX_ err_ref); 849 keysv=tmp_key.set(keysv); 850 return hv_fetch_ent(hv, keysv, lval, tmp_key.hash()); 851} 852 853constexpr U32 keyword_constant_flags = SVf_POK | SVf_IVisUV; 854 855bool is_keyword_constant(SV* sv) 856{ 857 return (SvFLAGS(sv) & keyword_constant_flags) == keyword_constant_flags; 858} 859 860} } } 861 862using namespace pm::perl::glue; 863 864MODULE = Polymake::RefHash PACKAGE = Polymake 865 866PROTOTYPES: DISABLE 867 868void is_keyword(SV* sv) 869PPCODE: 870{ 871 if (is_keyword_constant(sv)) 872 PUSHs(&PL_sv_yes); 873 else 874 PUSHs(&PL_sv_no); 875} 876 877void is_keyword_or_hash(SV* sv) 878PPCODE: 879{ 880 if (SvROK(sv) ? (sv = SvRV(sv), SvTYPE(sv) == SVt_PVHV && !SvSTASH(sv)) 881 : is_keyword_constant(sv)) 882 PUSHs(&PL_sv_yes); 883 else 884 PUSHs(&PL_sv_no); 885} 886 887MODULE = Polymake::RefHash PACKAGE = Polymake::RefHash 888 889void allow(SV* pkg) 890PPCODE: 891{ 892 av_push(allowed_pkgs, newRV((SV*)gv_stashsv(pkg,FALSE))); 893} 894 895BOOT: 896{ 897 my_pkg=gv_stashpv("Polymake::RefHash", FALSE); 898 allowed_pkgs=newAV(); 899 def_pp_CONST=PL_ppaddr[OP_CONST]; 900 def_pp_HELEM=PL_ppaddr[OP_HELEM]; 901 def_pp_HSLICE=PL_ppaddr[OP_HSLICE]; 902 def_pp_EXISTS=PL_ppaddr[OP_EXISTS]; 903 def_pp_DELETE=PL_ppaddr[OP_DELETE]; 904 def_pp_EACH=PL_ppaddr[OP_EACH]; 905 def_pp_KEYS=PL_ppaddr[OP_KEYS]; 906 def_pp_RV2HV=PL_ppaddr[OP_RV2HV]; 907 def_pp_PADHV=PL_ppaddr[OP_PADHV]; 908#if PerlVersion >= 5180 909 def_pp_PADRANGE=PL_ppaddr[OP_PADRANGE]; 910#endif 911 def_pp_ANONHASH=PL_ppaddr[OP_ANONHASH]; 912 def_ck_PUSH=PL_check[OP_PUSH]; 913#if PerlVersion >= 5220 914 def_ck_HELEM=PL_check[OP_HELEM]; 915 def_ck_EXISTS=PL_check[OP_EXISTS]; 916 def_ck_DELETE=PL_check[OP_DELETE]; 917#endif 918 namespace_register_plugin(aTHX_ catch_ptrs, reset_ptrs, &PL_sv_undef); 919} 920 921=pod 922// Local Variables: 923// mode:C++ 924// c-basic-offset:3 925// indent-tabs-mode:nil 926// End: 927=cut 928