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/glue.h" 19#include <sys/time.h> 20#include <sys/resource.h> 21 22namespace pm { namespace perl { namespace glue { 23namespace { 24 25GV* do_can(pTHX_ SV* obj, SV* method) 26{ 27 HV* stash = nullptr; 28 char* method_name = SvPVX(method); 29 I32 method_name_len = I32(SvCUR(method)); 30 31 if (SvGMAGICAL(obj)) mg_get(obj); 32 33 if (SvROK(obj)) { 34 obj = SvRV(obj); 35 if (SvOBJECT(obj)) { 36 stash = SvSTASH(obj); 37 } 38 } else if (SvPOKp(obj) && SvCUR(obj)) { 39 stash = gv_stashsv(obj, 0); 40 } 41 42 return stash ? gv_fetchmeth(stash, method_name, method_name_len, 0) : Nullgv; 43} 44 45MGVTBL array_flags_vtbl={ 0, 0, 0, 0, 0 }; 46 47int clear_weakref_wrapper(pTHX_ SV* sv, MAGIC* mg) 48{ 49 SV* owner = (SV*)mg->mg_ptr; 50 if (SvROK(sv)) Perl_croak(aTHX_ "attempt to re-parent a subobject"); 51 if (SvREFCNT(owner) > 1) { 52 dSP; 53 PUSHMARK(SP); 54 XPUSHs(sv_2mortal(newRV(owner))); 55 PUTBACK; 56 call_sv(mg->mg_obj, G_VOID | G_DISCARD); 57 } 58 return 0; 59} 60 61const MGVTBL clear_weakref_vtbl={ 0, &clear_weakref_wrapper, 0, 0, 0 }; 62 63GV* retrieve_gv(pTHX_ OP* o, OP* const_op, SV** const_sv, PERL_CONTEXT* cx, PERL_CONTEXT* cx_bottom) 64{ 65 GV* gv; 66#ifdef USE_ITHREADS 67 SV** saved_curpad = PL_curpad; 68 PL_curpad = get_cx_curpad(aTHX_ cx, cx_bottom); 69#endif 70#if PerlVersion >= 5220 71 if (o->op_type == OP_MULTIDEREF) { 72 UNOP_AUX_item* items = cUNOP_AUXo->op_aux; 73 gv = (GV*)UNOP_AUX_item_sv(++items); 74 if (const_sv) *const_sv = UNOP_AUX_item_sv(++items); 75 } else 76#endif 77 { 78 gv = cGVOPo_gv; 79 if (const_sv) *const_sv = cSVOPx_sv(const_op); 80 } 81#ifdef USE_ITHREADS 82 PL_curpad = saved_curpad; 83#endif 84 return gv; 85} 86 87OP* convert_eval_to_sub(pTHX) 88{ 89 CV* cv = cxstack[cxstack_ix].blk_sub.cv; 90 OP* start = PL_op->op_next; 91 OP* root = CvROOT(cv); 92 root->op_type = OP_LEAVESUB; 93 root->op_ppaddr = PL_ppaddr[OP_LEAVESUB]; 94 CvSTART(cv) = start; 95 return start; 96} 97 98MAGIC* array_flags_magic(pTHX_ SV* sv) 99{ 100 return mg_findext(sv, PERL_MAGIC_ext, &array_flags_vtbl); 101} 102 103} 104 105OP* select_method_helper_op(pTHX) 106{ 107 PL_op->op_ppaddr = PL_ppaddr[OP_ENTERSUB]; 108 ++PL_stack_sp; 109 return (PL_ppaddr[OP_ENTERSUB])(aTHX); 110} 111 112SV* name_of_ret_var(pTHX) 113{ 114 PERL_CONTEXT *const cx_bottom = cxstack, *cx = cx_bottom + cxstack_ix; 115 while (cx >= cx_bottom) { 116 if (CxTYPE(cx) == CXt_SUB && !skip_debug_frame(aTHX_ cx)) { 117 if (cx->blk_gimme != G_SCALAR) break; 118 OP* o = cx->blk_sub.retop; 119 if (!o) break; 120 while (o->op_type == OP_LEAVE) o = o->op_next; 121 if (o->op_type != OP_LEAVESUB && o->op_type != OP_LEAVESUBLV) { 122 // declare $x=...; produces different op patterns, depending on being in an allow-redeclare scope 123 if ((o->op_type == OP_GVSV && o->op_next->op_type == OP_SASSIGN) || 124 (o->op_type == OP_GV && 125 (o->op_next->op_type == OP_RV2SV && o->op_next->op_next->op_type == OP_SASSIGN) || 126 (o->op_next->op_type == OP_CONST && o->op_next->op_next->op_type == OP_RV2SV && o->op_next->op_next->op_next->op_type == OP_SASSIGN))) { 127 GV* gv = retrieve_gv(aTHX_ o, 0, 0, cx, cx_bottom); 128 return sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv))); 129 } 130 break; 131 } 132 } 133 --cx; 134 } 135 return nullptr; 136} 137 138SV* temp_errsv = nullptr; 139SV* true_errsv = nullptr; 140SV* boolean_string_sv[2]={ nullptr, nullptr }; 141 142int preserve_errsv(pTHX_ int idx, SV* bufsv, int maxlen) 143{ 144 ENTER; 145 save_sptr(&true_errsv); 146 true_errsv = ERRSV; 147 save_pushptrptr(PL_errgv, SvREFCNT_inc_simple(true_errsv), SAVEt_GVSV); 148 ERRSV = SvREFCNT_inc_simple_NN(temp_errsv); 149 filter_t runner = DPTR2FPTR(filter_t, FILTER_DATA(idx+1)); 150 int ret = runner(aTHX_ idx, bufsv, maxlen); 151 LEAVE; 152 return ret; 153} 154 155bool is_boolean_value(pTHX_ SV* sv) 156{ 157 if (sv == &PL_sv_yes || sv == &PL_sv_no) 158 return true; 159 160 constexpr auto boolean_const_flags = SVf_POK | SVf_NOK | SVf_IOK | SVp_POK | SVp_NOK | SVp_IOK; 161 // boolean lvalues in C++ objects must be recognized 162 auto no_magic_flags = SvTYPE(sv) == SVt_PVLV ? SVs_GMG | SVs_RMG : SVs_GMG | SVs_SMG | SVs_RMG; 163 if ((SvFLAGS(sv) & (boolean_const_flags | no_magic_flags)) == boolean_const_flags && 164 (SvIVX(sv) == 0 || SvIVX(sv) == 1) && 165 (SvCUR(sv) == 0 || SvCUR(sv) == 1 && SvPVX(sv)[0] == '1')) 166 return true; 167 168 return false; 169} 170 171SV* get_boolean_string(SV* sv) 172{ 173 return boolean_string_sv[SvIVX(sv)]; 174} 175 176} 177namespace ops { 178using namespace pm::perl::glue; 179 180OP* is_boolean(pTHX) 181{ 182 dSP; 183 dTOPss; 184 SV* result = is_boolean_value(aTHX_ sv) ? &PL_sv_yes : &PL_sv_no; 185 SETs(result); 186 RETURN; 187} 188 189OP* is_string(pTHX) 190{ 191 dSP; 192 dTOPss; 193 SV* result= (SvFLAGS(sv) & (SVf_IOK | SVf_NOK | SVf_POK | SVf_ROK | SVs_GMG | SVs_RMG)) == SVf_POK ? &PL_sv_yes : &PL_sv_no; 194 SETs(result); 195 RETURN; 196} 197 198OP* is_integer(pTHX) 199{ 200 dSP; 201 dTOPss; 202 SV* result = SvIOK(sv) ? &PL_sv_yes : &PL_sv_no; 203 SETs(result); 204 RETURN; 205} 206 207OP* is_float(pTHX) 208{ 209 dSP; 210 dTOPss; 211 SV* result = SvNOK(sv) ? &PL_sv_yes : &PL_sv_no; 212 SETs(result); 213 RETURN; 214} 215 216OP* is_numeric(pTHX) 217{ 218 dSP; 219 dTOPss; 220 SV* result = (!SvPOK(sv) || SvCUR(sv)>0) && (SvIOK(sv) | SvNOK(sv)) ? &PL_sv_yes : &PL_sv_no; 221 SETs(result); 222 RETURN; 223} 224 225OP* is_object(pTHX) 226{ 227 dSP; 228 dTOPss; 229 SV* result = SvROK(sv) && SvOBJECT(SvRV(sv)) ? &PL_sv_yes : &PL_sv_no; 230 SETs(result); 231 RETURN; 232} 233 234OP* is_code(pTHX) 235{ 236 dSP; 237 dTOPss; 238 SV* result = SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV ? &PL_sv_yes : &PL_sv_no; 239 SETs(result); 240 RETURN; 241} 242 243OP* is_constant_sub(pTHX) 244{ 245 dSP; 246 dTOPss; 247 CV* cv = SvROK(sv) ? (CV*)SvRV(sv) : SvTYPE(sv) == SVt_PVGV ? GvCV(sv) : nullptr; 248 SV* result = cv && CvCONST(cv) ? &PL_sv_yes : &PL_sv_no; 249 SETs(result); 250 RETURN; 251} 252 253OP* is_array(pTHX) 254{ 255 dSP; 256 dTOPss; 257 SV* result = SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) == SVt_PVAV ? &PL_sv_yes : &PL_sv_no; 258 SETs(result); 259 RETURN; 260} 261 262OP* is_hash(pTHX) 263{ 264 dSP; 265 dTOPss; 266 SV* result = SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) == SVt_PVHV ? &PL_sv_yes : &PL_sv_no; 267 SETs(result); 268 RETURN; 269} 270 271OP* is_scalar_ref(pTHX) 272{ 273 dSP; 274 dTOPss; 275 SV* result = SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) <= SVt_PVMG ? &PL_sv_yes : &PL_sv_no; 276 SETs(result); 277 RETURN; 278} 279 280OP* is_like_array(pTHX) 281{ 282 dSP; 283 dTOPss; 284 SV* result = &PL_sv_no; 285 if (SvROK(sv)) { 286 SV* obj = SvRV(sv); 287 if (SvOBJECT(obj)) { 288 if (SvRMAGICAL(obj) && SvTYPE(obj) == SVt_PVAV) { 289 if (MAGIC* mg = mg_find(obj, PERL_MAGIC_tied)) { 290 // canned C++ containers and composites both behave as magic arrays in perl machinery, 291 // but composites should not be viewed as arrays in the sense of application logic 292 if (mg->mg_virtual->svt_dup != &canned_dup || 293 (as_vtbl<base_vtbl>(mg)->flags & ClassFlags::kind_mask) == ClassFlags::is_container) 294 result = &PL_sv_yes; 295 } 296 } else if (SvAMAGIC(sv) && gv_fetchmeth(SvSTASH(obj), "(@{}", 4, 0)) { 297 result = &PL_sv_yes; 298 } 299 } else { 300 if (SvTYPE(obj) == SVt_PVAV) 301 result = &PL_sv_yes; 302 } 303 } 304 SETs(result); 305 RETURN; 306} 307 308OP* is_like_hash(pTHX) 309{ 310 dSP; 311 dTOPss; 312 SV* result = &PL_sv_no; 313 if (SvROK(sv)) { 314 SV* obj = SvRV(sv); 315 if (SvOBJECT(obj)) { 316 if (SvRMAGICAL(obj) && SvTYPE(obj) == SVt_PVHV) { 317 if (mg_find(obj, PERL_MAGIC_tied)) 318 result = &PL_sv_yes; 319 } else if (SvAMAGIC(sv) && gv_fetchmeth(SvSTASH(obj), "(%{}", 4, 0)) { 320 result = &PL_sv_yes; 321 } 322 } else { 323 if (SvTYPE(obj) == SVt_PVHV) 324 result = &PL_sv_yes; 325 } 326 } 327 SETs(result); 328 RETURN; 329} 330 331OP* make_weak(pTHX) 332{ 333 dSP; 334 dPOPss; 335 sv_rvweaken(sv); 336 RETURN; 337} 338 339OP* is_defined_and_false(pTHX) 340{ 341 dSP; 342 dTOPss; 343 SV* result = SvIOK(sv) && SvIVX(sv)==0 ? &PL_sv_yes : &PL_sv_no; 344 SETs(result); 345 RETURN; 346} 347 348 349} } } 350 351using namespace pm::perl::glue; 352 353MODULE = Polymake PACKAGE = Polymake 354 355I32 refcnt(SV* x) 356PROTOTYPE: $ 357CODE: 358{ 359 if (SvROK(x)) x=SvRV(x); 360 RETVAL=SvREFCNT(x); 361} 362OUTPUT: 363 RETVAL 364 365void refcmp(SV* x, SV* y, ...) 366PPCODE: 367{ 368 SV* result= SvRV(x)==SvRV(y) ? &PL_sv_yes : &PL_sv_no; 369 PUSHs(result); 370} 371 372void guarded_weak(SV* ref, SV* owner, SV* clear_cv) 373PROTOTYPE: $$$ 374PPCODE: 375{ 376 sv_rvweaken(ref); 377 MAGIC* mg = sv_magicext(ref, SvRV(clear_cv), PERL_MAGIC_ext, &clear_weakref_vtbl, nullptr, 0); 378 mg->mg_ptr = (char*)SvRV(owner); 379} 380 381void readonly(SV* x) 382PROTOTYPE: $ 383PPCODE: 384{ 385 write_protect_on(aTHX_ x); 386 ++SP; 387} 388 389void readonly_deref(SV* x) 390PROTOTYPE: $ 391PPCODE: 392{ 393 if (SvROK(x)) { 394 x = SvRV(x); 395 write_protect_on(aTHX_ x); 396 MAGIC* mg; 397 if (SvMAGICAL(x) && (mg = get_cpp_magic(x))) { 398 mg->mg_flags |= uint8_t(pm::perl::ValueFlags::read_only); 399 } 400 } else { 401 write_protect_on(aTHX_ x); 402 } 403 ++SP; 404} 405 406void readonly_off(SV* x) 407PROTOTYPE: $ 408PPCODE: 409{ 410 write_protect_off(aTHX_ x); 411 ++SP; 412} 413 414void is_readonly(SV* x) 415PROTOTYPE: $ 416PPCODE: 417{ 418 if (SvREADONLY(x)) 419 PUSHs(&PL_sv_yes); 420 else 421 PUSHs(&PL_sv_no); 422} 423 424I32 is_lvalue(SV* subref) 425PROTOTYPE: $ 426CODE: 427{ 428 CV* sub; 429 if (!SvROK(subref) || (sub=(CV*)SvRV(subref), SvTYPE(sub) != SVt_PVCV)) 430 croak_xs_usage(cv, "\\&sub"); 431 if (CvLVALUE(sub)) { 432 RETVAL = CvISXSUB(sub) || CvROOT(sub)->op_type != OP_LEAVESUBLV ? magic_lvalue : pure_lvalue; 433 } else { 434 RETVAL = no_lvalue; 435 } 436} 437OUTPUT: 438 RETVAL 439 440void is_method(SV* sub) 441PROTOTYPE: $ 442PPCODE: 443{ 444 SV* result=&PL_sv_no; 445 if (!SvROK(sub)) { 446 if (SvPOKp(sub)) result=&PL_sv_yes; // presumably the method name 447 } else { 448 sub=SvRV(sub); 449 if (SvTYPE(sub) != SVt_PVCV) 450 croak_xs_usage(cv, "\\&sub"); 451 if (CvMETHOD(sub)) result=&PL_sv_yes; 452 } 453 PUSHs(result); 454} 455 456void select_method(SV* sub, ...) 457PPCODE: 458{ 459 // TODO: try to eliminate or simplify significantly, much of the logic here is not used any longer 460 int push = 0, i; 461 SV** stack; 462 SV** bottom; 463 if (SvROK(sub)) { 464 sub = SvRV(sub); 465 if (SvTYPE(sub) != SVt_PVCV) 466 croak_xs_usage(cv, "\"method_name\" || \\&sub, Object, ..."); 467 if (CvMETHOD(sub)) { 468 if (items == 3 && SvIOK(ST(2)) && SvIVX(ST(2)) == 1) { 469 push = 1; goto push_obj; 470 } else { 471 HV* method_stash = GvSTASH(CvGV(sub)); 472 for (i = 1; i < items; ++i) { 473 SV *obj_ref = ST(i); 474 if (SvSTASH(SvRV(obj_ref)) == method_stash || sv_derived_from(obj_ref, HvNAME(method_stash))) { 475 push = i; goto push_obj; 476 } 477 } 478 } 479 Perl_croak(aTHX_ "no suitable object found"); 480 } else { 481 goto ready; 482 } 483 } else if (SvPOKp(sub)) { 484 for (i = 1; i < items; ++i) { 485 GV *method_gv = do_can(aTHX_ ST(i), sub); 486 if (method_gv) { 487 SV* cache_here = sub; 488 sub = (SV*)GvCV(method_gv); 489 if (sub) { 490 if (!(SvFLAGS(cache_here) & (SVs_TEMP | SVf_FAKE | SVf_READONLY))) { 491 sv_setsv(cache_here, sv_2mortal(newRV(sub))); 492 } 493 if (CvMETHOD(sub)) { 494 push = i; goto push_obj; 495 } else { 496 goto ready; 497 } 498 } 499 } 500 } 501 Perl_croak(aTHX_ "method not found"); 502 } else { 503 croak_xs_usage(cv, "\"method_name\" || \\&sub, Object, ..."); 504 } 505 push_obj: 506 for (stack = ++SP, bottom = PL_stack_base+TOPMARK+1; stack > bottom; --stack) 507 *stack = stack[-1]; 508 *stack = ST(push); 509 ready: 510 if (PL_op->op_next->op_type == OP_ENTERSUB) { 511 PUSHs(sub); 512 if (GIMME_V == G_SCALAR) { 513 PL_op->op_flags ^= OPf_WANT_SCALAR ^ OPf_WANT_LIST; 514 if (push) { 515 --SP; 516 PL_op->op_next->op_ppaddr = &select_method_helper_op; 517 } 518 } 519 } else { 520 PUSHs(sv_2mortal(newRV(sub))); 521 } 522} 523 524void mark_as_utf8string(SV* x) 525PROTOTYPE: $ 526PPCODE: 527{ 528 SvUTF8_on(x); 529 ++SP; 530} 531 532void extract_boolean(SV* x) 533PROTOTYPE: $ 534PPCODE: 535{ 536 SV* result = nullptr; 537 if (is_boolean_value(aTHX_ x)) { 538 result = x; 539 } else if (SvIOK(x)) { 540 if (SvIVX(x) == 1) 541 result = &PL_sv_yes; 542 else if (SvIVX(x) == 0) 543 result = &PL_sv_no; 544 else 545 Perl_croak(aTHX_ "parse error: invalid boolean value %" IVdf ", allowed values are 0 and 1", SvIVX(x)); 546 } else if (SvPOK(x)) { 547 STRLEN l; 548 char* s = SvPV(x, l); 549 // tolerate trailing spaces 550 while (l > 1 && isSPACE(s[l-1])) --l; 551 switch (l) { 552 case 1: 553 if (*s == '1') 554 result = &PL_sv_yes; 555 else if (*s == '0') 556 result = &PL_sv_no; 557 break; 558 case 4: 559 if (!strncmp(s, "true", 4)) 560 result = &PL_sv_yes; 561 break; 562 case 5: 563 if (!strncmp(s, "false", 5)) 564 result = &PL_sv_no; 565 break; 566 } 567 if (!result) 568 Perl_croak(aTHX_ "parse error: invalid boolean value '%.*s', allowed values are 0, 1, 'false', 'true'", (int)l, s); 569 } 570 PUSHs(result); 571} 572 573void extract_integer(SV* str) 574PROTOTYPE: $ 575PPCODE: 576{ 577 dTARGET; 578 STRLEN l; 579 char* start = SvPV(str, l); 580 char* end = nullptr; 581 long val = strtol(start, &end, 10); 582 for (; end < start + l; ++end) 583 if (!isSPACE(*end)) 584 Perl_croak(aTHX_ "parse error: invalid integer value %.*s", (int)l, start); 585 PUSHi(val); 586} 587 588void extract_float(SV* str) 589PROTOTYPE: $ 590PPCODE: 591{ 592 dTARGET; 593 STRLEN l; 594 char* start = SvPV(str, l); 595#ifdef my_atof2 596 NV val = 0; 597 char* end = my_atof2(start, &val); 598#else 599 char* end = nullptr; 600 NV val = strtod(start, &end); 601#endif 602 for (; end < start+l; ++end) 603 if (!isSPACE(*end)) 604 Perl_croak(aTHX_ "parse error: invalid floating-point value %.*s", (int)l, start); 605 PUSHn(val); 606} 607 608void to_boolean_string(SV* x) 609PROTOTYPE: $ 610PPCODE: 611{ 612 // be paranoid 613 SV* bool_sv=is_boolean_value(aTHX_ x) ? x : SvTRUE(x) ? &PL_sv_yes : &PL_sv_no; 614 SV* result=get_boolean_string(bool_sv); 615 PUSHs(result); 616} 617 618void inherit_class(SV* obj, SV* src) 619PPCODE: 620{ 621 HV* stash; 622 if (SvROK(src)) { 623 src = SvRV(src); 624 if (SvOBJECT(src)) { 625 stash = SvSTASH(src); 626 sv_bless(obj, stash); 627 } 628 } else if (SvPOK(src)) { 629 if (!(stash = gv_stashsv(src, FALSE))) 630 Perl_croak(aTHX_ "unknown package %.*s", (int)SvCUR(src), SvPVX(src)); 631 sv_bless(obj, stash); 632 } else { 633 croak_xs_usage(cv, "newObject, \"pkg\" || otherObject"); 634 } 635 ++SP; // let obj appear at the stack top again 636} 637 638void get_symtab(SV* pkg_name, ...) 639PPCODE: 640{ 641 const bool create_new = items == 2 && SvTRUE(ST(1)); 642 // do not cache stash pointers in lexical variables and string literals 643 const bool cache_result = !create_new && !(SvFLAGS(pkg_name) & (SVf_READONLY | SVs_PADTMP | SVs_PADMY)); 644 if (HV* stash = cache_result ? get_cached_stash(aTHX_ pkg_name) : gv_stashsv(pkg_name, create_new)) 645 PUSHs(sv_2mortal(newRV((SV*)stash))); 646 else 647 Perl_croak(aTHX_ "unknown package %.*s", (int)SvCUR(pkg_name), SvPVX(pkg_name)); 648} 649 650void defined_scalar(SV* gv) 651PROTOTYPE: $ 652PPCODE: 653{ 654 SV* sv; 655 SV* result = SvTYPE(gv) == SVt_PVGV && (sv = GvSV(gv)) && SvOK(sv) ? &PL_sv_yes : &PL_sv_no; 656 PUSHs(result); 657} 658 659void declared_scalar(SV* gv) 660PROTOTYPE: $ 661PPCODE: 662{ 663 SV* result = SvTYPE(gv) == SVt_PVGV && GvIMPORTED_SV(gv) ? &PL_sv_yes : &PL_sv_no; 664 PUSHs(result); 665} 666 667void unimport_function(SV* gv) 668PROTOTYPE: $ 669CODE: 670{ 671 if (CV* funcv = GvCV(gv)) { 672 SvREFCNT_dec(funcv); 673 GvCV_set(gv, Nullcv); 674 } 675 GvIMPORTED_CV_off(gv); 676 GvASSUMECV_off(gv); 677} 678 679void method_name(SV* sub) 680PROTOTYPE: $ 681PPCODE: 682{ 683 if (!SvROK(sub) || (sub = SvRV(sub), SvTYPE(sub) != SVt_PVCV)) 684 croak_xs_usage(cv, "\\&sub"); 685 dTARGET; 686 GV* subgv = CvGV(sub); 687 PUSHp(GvNAME(subgv), GvNAMELEN(subgv)); 688} 689 690void sub_pkg(SV* sub) 691PROTOTYPE: $ 692PPCODE: 693{ 694 if (SvROK(sub)) { 695 dTARGET; 696 HV* stash; 697 sub = SvRV(sub); 698 if (SvTYPE(sub) != SVt_PVCV) 699 croak_xs_usage(cv, "\\&sub"); 700 stash = CvSTASH(sub); 701 PUSHp(HvNAME(stash), HvNAMELEN(stash)); 702 } else { 703 PUSHs(&PL_sv_undef); 704 } 705} 706 707void sub_file(SV* sub) 708PROTOTYPE: $ 709PPCODE: 710{ 711 if (!SvROK(sub) || (sub = SvRV(sub), SvTYPE(sub) != SVt_PVCV)) 712 croak_xs_usage(cv, "\\&sub"); 713 if (CvSTART(sub)) { 714 dTARGET; 715 sv_setpv(TARG, CopFILE((COP*)CvSTART(sub))); 716 PUSHs(TARG); 717 } else { 718 PUSHs(&PL_sv_undef); 719 } 720} 721 722void sub_firstline(SV* sub) 723PROTOTYPE: $ 724PPCODE: 725{ 726 if (!SvROK(sub) || (sub = SvRV(sub), SvTYPE(sub) != SVt_PVCV)) 727 croak_xs_usage(cv, "\\&sub"); 728 if (CvSTART(sub)) { 729 dTARGET; 730 PUSHi(CopLINE((COP*)CvSTART(sub))); 731 } else { 732 PUSHs(&PL_sv_undef); 733 } 734} 735 736void method_owner(SV* sub) 737PROTOTYPE: $ 738PPCODE: 739{ 740 dTARGET; 741 if (!SvROK(sub) || (sub = SvRV(sub), SvTYPE(sub) != SVt_PVCV)) 742 croak_xs_usage(cv, "\\&sub"); 743 HV* stash = GvSTASH(CvGV(sub)); 744 PUSHp(HvNAME(stash), HvNAMELEN(stash)); 745} 746 747void define_function(SV* pkg, SV* name_sv, SV* sub, ...) 748PPCODE: 749if (!SvROK(sub) || 750 (sub=SvRV(sub), SvTYPE(sub) != SVt_PVCV) || 751 SvROK(name_sv) || 752 (!SvPOK(pkg) && (!SvROK(pkg) || SvTYPE(SvRV(pkg))!=SVt_PVHV))) { 753 croak_xs_usage(cv, "\"pkg\" || \\%%stash, \"name\", \\&sub [, TRUE ]"); 754} else { 755 HV* pkg_stash=SvROK(pkg) ? (HV*)SvRV(pkg) : gv_stashsv(pkg, items>3 && SvTRUE(ST(3)) ? GV_ADD : 0); 756 if (!pkg_stash) 757 Perl_croak(aTHX_ "unknown package %.*s", (int)SvCUR(pkg), SvPVX(pkg)); 758 759 STRLEN namelen; 760 const char* name = SvPV(name_sv, namelen); 761 GV* glob = (GV*)*hv_fetch(pkg_stash, name, I32(namelen), TRUE); 762 if (SvTYPE(glob) != SVt_PVGV) 763 gv_init_pvn(glob, pkg_stash, name, namelen, GV_ADDMULTI); 764 765 sv_setsv((SV*)glob, ST(2)); 766 if (CvANON(sub)) { 767 CvANON_off(sub); 768 CvGV_set((CV*)sub, glob); 769 if (!CvISXSUB(sub)) { 770 SV* file=CopFILESV((COP*)CvSTART(sub)); 771 if (file && (!SvOK(file) || !SvPVX(file) || !strncmp(SvPVX(file), "(eval ", 6))) 772 sv_setpvf(file, "(%.*s::%.*s)", PmPrintHvNAME(pkg_stash), (int)namelen, name); 773 } 774 } 775 PUSHs(ST(2)); 776 if (CvMETHOD(sub)) { 777 PUTBACK; 778 Perl_mro_method_changed_in(aTHX_ pkg_stash); 779 } 780} 781 782 783void can(SV* obj, SV* method, ...) 784PPCODE: 785{ 786 GV* glob = do_can(aTHX_ obj, method); 787 if (glob) 788 PUSHs( sv_2mortal(newRV((SV*)GvCV(glob))) ); 789 else 790 PUSHs( &PL_sv_undef ); 791} 792 793 794void set_method(SV* sub) 795PROTOTYPE: $ 796PPCODE: 797{ 798 CvMETHOD_on(SvRV(sub)); 799} 800 801void ones(SV* bitset) 802PROTOTYPE: $ 803PPCODE: 804{ 805 I32 gimme = GIMME_V; 806 if (SvOK(bitset)) { 807 SSize_t l = SvCUR(bitset) << 3, i; 808 const unsigned char* s = (unsigned char*)SvPVX(bitset); 809 unsigned int bit = 1; 810 EXTEND(SP, l); 811 for (i = 0; i < l; ++i) { 812 if ((*s) & bit) { 813 PUSHs(sv_2mortal(newSViv(i))); 814 if (gimme == G_SCALAR) break; 815 } 816 if ((bit <<= 1) == (1<<8)) { 817 ++s; bit = 1; 818 } 819 } 820 } 821} 822 823void swap_deref(SV* ref1, SV* ref2) 824PPCODE: 825{ 826 // exchange two scalars/objects/lists/hashes behind given references 827 if (!SvROK(ref1) || !SvROK(ref2)) 828 croak_xs_usage(cv, "$ref1, $ref2"); 829 SV* sv1 = SvRV(ref1); 830 SV* sv2 = SvRV(ref2); 831 std::swap(SvANY(sv1), SvANY(sv2)); 832 std::swap(SvFLAGS(sv1), SvFLAGS(sv2)); 833 std::swap(sv1->sv_u, sv2->sv_u); 834} 835 836void capturing_group_boundaries(SV* name) 837PPCODE: 838{ 839 if (PL_curpm) { 840 REGEXP* re = PM_GETRE(PL_curpm); 841 struct regexp* rx; 842 if (re && (rx = ReANY(re), RXp_PAREN_NAMES(rx))) { 843 HE* he_str = hv_fetch_ent(RXp_PAREN_NAMES(rx), name, 0, 0); 844 if (he_str) { 845 SV* sv_dat = HeVAL(he_str); 846 I32* nums = (I32*)SvPVX(sv_dat); 847 for (I32 i = 0; i < SvIVX(sv_dat); i++) { 848 if (I32(rx->nparens) >= nums[i]) { 849 I32 start = I32(rx->offs[nums[i]].start); 850 I32 end = I32(rx->offs[nums[i]].end); 851 if (start != -1 && end != -1) { 852 XPUSHs(sv_2mortal(newSViv(start))); 853 XPUSHs(sv_2mortal(newSViv(end))); 854 break; 855 } 856 } 857 } 858 } 859 } 860 } 861} 862 863void disable_debugging() 864PPCODE: 865{ 866 PL_runops = PL_runops_std; 867} 868 869void enable_debugging() 870PPCODE: 871{ 872 PL_runops = PL_runops_dbg; 873} 874 875void stop_here_gdb(...) 876PPCODE: 877{ 878 if (items > 0) { 879 SV* x = ST(0); 880 assert(SvANY(x)); 881 PERL_UNUSED_VAR(x); 882 ++SP; 883 } 884} 885 886void 887get_user_cpu_time() 888PPCODE: 889{ 890 dTARGET; 891 struct rusage ru; 892 double result = getrusage(RUSAGE_SELF, &ru)<0 893 ? -1 894 : (double)ru.ru_utime.tv_sec + (double)ru.ru_utime.tv_usec * 1e-6; 895 XPUSHn(result); 896} 897 898 899MODULE = Polymake PACKAGE = Polymake::Core 900 901void name_of_arg_var(I32 arg_no) 902PPCODE: 903{ 904 PUSHs(&PL_sv_undef); // default answer 905 906 for (PERL_CONTEXT *cx_bottom = cxstack, *cx = cx_bottom+cxstack_ix; cx >= cx_bottom; --cx) { 907 if (CxTYPE(cx)==CXt_SUB && !skip_debug_frame(aTHX_ cx)) { 908 OP* o = cx->blk_oldcop->op_next; 909 if (o->op_type == OP_PUSHMARK) { 910 do { 911 o = OpSIBLING(o); 912 } while (o && --arg_no >= 0); 913 if (o) { 914 if (o->op_type == OP_NULL) 915 o = cUNOPo->op_first; 916 if (o->op_type == OP_GVSV) { 917 dTARGET; 918 GV* gv = retrieve_gv(aTHX_ o, 0, 0, cx, cx_bottom); 919 sv_setpvn(TARG, GvNAME(gv), GvNAMELEN(gv)); 920 SETs(TARG); 921 } 922 } 923 } 924 break; 925 } 926 } 927} 928 929void name_of_ret_var() 930PPCODE: 931{ 932 SV* var_sv = name_of_ret_var(aTHX); 933 if (var_sv) 934 XPUSHs(var_sv); 935 else 936 XPUSHs(&PL_sv_undef); 937} 938 939void get_array_flags(SV* avref) 940PPCODE: 941{ 942 SV* av; 943 if (SvROK(avref) && (av = SvRV(avref), SvTYPE(av) == SVt_PVAV)) { 944 MAGIC* mg = array_flags_magic(aTHX_ av); 945 if (mg) { 946 dTARGET; 947 PUSHi(mg->mg_len); 948 } else { 949 PUSHs(&PL_sv_undef); 950 } 951 } else { 952 croak_xs_usage(cv, "\\@array"); 953 } 954} 955 956void set_array_flags(SV* avref, I32 flags) 957PPCODE: 958{ 959 SV* av; 960 if (SvROK(avref) && (av = SvRV(avref), SvTYPE(av) == SVt_PVAV)) { 961 MAGIC* mg = array_flags_magic(aTHX_ av); 962 if (!mg) 963 mg = sv_magicext(av, Nullsv, PERL_MAGIC_ext, &array_flags_vtbl, nullptr, 0); 964 mg->mg_len = flags; 965 } else { 966 croak_xs_usage(cv, "\\@array, flags"); 967 } 968} 969 970void compiling_in(...) 971PPCODE: 972{ 973 HV* stash = PL_curstash; 974 if (items == 0) { 975 XPUSHs(sv_2mortal(newRV((SV*)stash))); 976 } else { 977 SV* where = ST(0); 978 if (SvROK(where)) { 979 PUSHs(stash == (HV*)SvRV(where) ? &PL_sv_yes : &PL_sv_no); 980 } else { 981 STRLEN pkgname_len; 982 const char* pkgname = SvPV(where, pkgname_len); 983 PUSHs(STRLEN(HvNAMELEN(stash)) == pkgname_len && !strncmp(pkgname, HvNAME(stash), pkgname_len) ? &PL_sv_yes : &PL_sv_no); 984 } 985 } 986} 987 988void compiling_in_pkg() 989PPCODE: 990{ 991 dTARGET; 992 HV* stash = PL_curstash; 993 PUSHp(HvNAME(stash), HvNAMELEN(stash)); 994} 995 996void compiling_in_sub() 997PPCODE: 998{ 999 CV* in_cv = PL_compcv; 1000 if (in_cv && SvTYPE(in_cv)==SVt_PVCV && (!CvUNIQUE(in_cv) || SvFAKE(in_cv))) 1001 XPUSHs(&PL_sv_yes); 1002 else 1003 XPUSHs(&PL_sv_no); 1004} 1005 1006void defuse_environ_bug() 1007PPCODE: 1008{ 1009#if !defined(__APPLE__) 1010 PL_origenviron = environ; 1011#endif 1012} 1013 1014 1015void inject_error_preserving_source_filter() 1016PPCODE: 1017{ 1018 AV* filters = PL_parser->rsfp_filters; 1019 I32 last_filter = I32(AvFILLp(filters)); 1020 assert(last_filter >= 0); 1021 SV* filter_data = FILTER_DATA(last_filter); 1022 assert(SvTYPE(filter_data) == SVt_PVIO); 1023 filter_t runner = DPTR2FPTR(filter_t, IoANY(filter_data)); 1024 if (AvMAX(filters) == last_filter) 1025 av_extend(filters, last_filter+1); 1026 AvARRAY(filters)[last_filter+1] = (SV*)runner; 1027 IoANY(filter_data) = FPTR2DPTR(void*, &preserve_errsv); 1028 if (!temp_errsv) temp_errsv = newSVpvn("", 0); 1029 XSRETURN_YES; 1030} 1031 1032void remove_error_preserving_source_filter() 1033PPCODE: 1034{ 1035 AV* filters = PL_parser->rsfp_filters; 1036 I32 last_filter = I32(AvFILLp(filters)); 1037 assert(last_filter >= 0 && AvMAX(filters) > last_filter); 1038 SV* filter_data = FILTER_DATA(last_filter); 1039 assert(SvTYPE(filter_data) == SVt_PVIO); 1040 IoANY(filter_data) = FILTER_DATA(last_filter+1); 1041} 1042 1043void get_preserved_errors() 1044PPCODE: 1045{ 1046 SV* ret = true_errsv; 1047 if (!ret) ret = &PL_sv_undef; 1048 XPUSHs(ret); 1049} 1050 1051 1052void rescue_static_code(I32 for_script) 1053PPCODE: 1054{ 1055 /* We must convert a "one-shot" sub made for eval to a real persistent sub: 1056 1. In script mode, short-circuit this operation, making the first real op in the script 1057 the start one for all future calls. 1058 In rulefile mode, rewind back to the first real op of the rule sub. 1059 2. Prepare the special start operation converting the root to LEAVESUB, 1060 since all subsequent calls will be made via ENTERSUB. 1061 This op will reside in an unused NULL enclosing this XSUB's call. 1062 3. Store the root operation (LEAVEEVAL) and increase its refcount, 1063 otherwise get destroyed in pp_require 1064 4. Provide CvDEPTH be decreased on exit, since LEAVEEVAL doesn't always care about it, 1065 in particular when the script execution is terminated by an exception. 1066 */ 1067 OP* start=PL_op; 1068 OP* tmp_start=cUNOPx(start)->op_first; 1069 OP* root=PL_eval_root; 1070 PERL_CONTEXT* cx=cxstack+cxstack_ix; 1071 CV* script_cv; 1072 // 1. 1073 if (for_script) { 1074 script_cv=cx->blk_eval.cv; 1075 while (start->op_type != OP_NEXTSTATE && start->op_type != OP_DBSTATE && start->op_type != OP_LEAVEEVAL) { 1076 start=start->op_next; 1077 } 1078 } else if (CxTYPE(cx) == CXt_EVAL && (script_cv=cx->blk_eval.cv, CvUNIQUE(script_cv))) { 1079 start=cLISTOPx(cUNOPx(root)->op_first)->op_first; 1080 } else { 1081 // repeated call 1082 XSRETURN_EMPTY; 1083 } 1084 // 2. 1085 CvSTART(script_cv)=tmp_start; 1086 CvANON_on(script_cv); 1087 CvGV_set(script_cv, (PerlVersion < 5200 ? (GV*)&PL_sv_undef : Nullgv)); 1088 tmp_start->op_next=start; 1089 tmp_start->op_ppaddr=&convert_eval_to_sub; 1090 // 3. 1091 CvEVAL_off(script_cv); 1092 OP_REFCNT_LOCK; 1093 OpREFCNT_inc(root); 1094 OP_REFCNT_UNLOCK; 1095 CvROOT(script_cv)=root; 1096 PUSHs(sv_2mortal(newRV((SV*)script_cv))); 1097 // 4. 1098 LEAVE; 1099 CvDEPTH(script_cv)=0; 1100 SAVEI32(CvDEPTH(script_cv)); 1101 CvDEPTH(script_cv)=1; 1102 ENTER; 1103} 1104 1105 1106BOOT: 1107{ 1108 if (PL_DBgv) { 1109 CvNODEBUG_on(get_cv("Polymake::select_method", FALSE)); 1110 CvNODEBUG_on(get_cv("Polymake::disable_debugging", FALSE)); 1111 CvNODEBUG_on(get_cv("Polymake::enable_debugging", FALSE)); 1112 CvNODEBUG_on(get_cv("Polymake::capturing_group_boundaries", FALSE)); 1113 CvNODEBUG_on(get_cv("Polymake::Core::name_of_arg_var", FALSE)); 1114 CvNODEBUG_on(get_cv("Polymake::Core::name_of_ret_var", FALSE)); 1115 CvNODEBUG_on(get_cv("Polymake::Core::rescue_static_code", FALSE)); 1116 } 1117 CvFLAGS(get_cv("Polymake::readonly", FALSE)) |= CVf_NODEBUG | CVf_LVALUE; 1118 CvFLAGS(get_cv("Polymake::readonly_off", FALSE)) |= CVf_NODEBUG | CVf_LVALUE; 1119 CvFLAGS(get_cv("Polymake::stop_here_gdb", FALSE)) |= CVf_NODEBUG | CVf_LVALUE; 1120 1121 boolean_string_sv[0]=newSVpvn_share("false",5,0); 1122 boolean_string_sv[1]=newSVpvn_share("true",4,0); 1123} 1124 1125=pod 1126// Local Variables: 1127// mode:C++ 1128// c-basic-offset:3 1129// indent-tabs-mode:nil 1130// End: 1131=cut 1132