1 #line 2 "universal.c" 2 /* universal.c 3 * 4 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 5 * 2005, 2006, 2007, 2008 by Larry Wall and others 6 * 7 * You may distribute under the terms of either the GNU General Public 8 * License or the Artistic License, as specified in the README file. 9 * 10 */ 11 12 /* 13 * '"The roots of those mountains must be roots indeed; there must be 14 * great secrets buried there which have not been discovered since the 15 * beginning."' --Gandalf, relating Gollum's history 16 * 17 * [p.54 of _The Lord of the Rings_, I/ii: "The Shadow of the Past"] 18 */ 19 20 /* This file contains the code that implements the functions in Perl's 21 * UNIVERSAL package, such as UNIVERSAL->can(). 22 * 23 * It is also used to store XS functions that need to be present in 24 * miniperl for a lack of a better place to put them. It might be 25 * clever to move them to separate XS files which would then be pulled 26 * in by some to-be-written build process. 27 */ 28 29 #include "EXTERN.h" 30 #define PERL_IN_UNIVERSAL_C 31 #include "perl.h" 32 33 #if defined(USE_PERLIO) 34 #include "perliol.h" /* For the PERLIO_F_XXX */ 35 #endif 36 37 /* 38 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com> 39 * The main guts of traverse_isa was actually copied from gv_fetchmeth 40 */ 41 42 #define PERL_ARGS_ASSERT_ISA_LOOKUP \ 43 assert(stash); \ 44 assert(namesv || name) 45 46 47 STATIC bool 48 S_isa_lookup(pTHX_ HV *stash, SV *namesv, const char * name, STRLEN len, U32 flags) 49 { 50 const struct mro_meta *const meta = HvMROMETA(stash); 51 HV *isa = meta->isa; 52 const HV *our_stash; 53 54 PERL_ARGS_ASSERT_ISA_LOOKUP; 55 56 if (!isa) { 57 (void)mro_get_linear_isa(stash); 58 isa = meta->isa; 59 } 60 61 if (hv_common(isa, namesv, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0), 62 HV_FETCH_ISEXISTS, NULL, 0)) { 63 /* Direct name lookup worked. */ 64 return TRUE; 65 } 66 67 /* A stash/class can go by many names (ie. User == main::User), so 68 we use the HvENAME in the stash itself, which is canonical, falling 69 back to HvNAME if necessary. */ 70 our_stash = gv_stashsvpvn_cached(namesv, name, len, flags); 71 72 if (our_stash) { 73 HEK *canon_name = HvENAME_HEK(our_stash); 74 if (!canon_name) canon_name = HvNAME_HEK(our_stash); 75 assert(canon_name); 76 if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name), 77 HEK_FLAGS(canon_name), 78 HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) { 79 return TRUE; 80 } 81 } 82 83 return FALSE; 84 } 85 86 #define PERL_ARGS_ASSERT_SV_DERIVED_FROM_SVPVN \ 87 assert(sv); \ 88 assert(namesv || name) 89 90 STATIC bool 91 S_sv_derived_from_svpvn(pTHX_ SV *sv, SV *namesv, const char * name, const STRLEN len, U32 flags) 92 { 93 HV* stash; 94 95 PERL_ARGS_ASSERT_SV_DERIVED_FROM_SVPVN; 96 SvGETMAGIC(sv); 97 98 if (SvROK(sv)) { 99 const char *type; 100 sv = SvRV(sv); 101 type = sv_reftype(sv,0); 102 if (type) { 103 if (namesv) 104 name = SvPV_nolen(namesv); 105 if (strEQ(name, type)) 106 return TRUE; 107 } 108 if (!SvOBJECT(sv)) 109 return FALSE; 110 stash = SvSTASH(sv); 111 } 112 else { 113 stash = gv_stashsv(sv, 0); 114 } 115 116 if (stash && isa_lookup(stash, namesv, name, len, flags)) 117 return TRUE; 118 119 stash = gv_stashpvs("UNIVERSAL", 0); 120 return stash && isa_lookup(stash, namesv, name, len, flags); 121 } 122 123 /* 124 =for apidoc_section $SV 125 126 =for apidoc sv_derived_from_pvn 127 128 Returns a boolean indicating whether the SV is derived from the specified class 129 I<at the C level>. To check derivation at the Perl level, call C<isa()> as a 130 normal Perl method. 131 132 Currently, the only significant value for C<flags> is SVf_UTF8. 133 134 =cut 135 136 =for apidoc sv_derived_from_sv 137 138 Exactly like L</sv_derived_from_pvn>, but takes the name string in the form 139 of an SV instead of a string/length pair. This is the advised form. 140 141 =cut 142 143 */ 144 145 bool 146 Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags) 147 { 148 PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV; 149 return sv_derived_from_svpvn(sv, namesv, NULL, 0, flags); 150 } 151 152 /* 153 =for apidoc sv_derived_from 154 155 Exactly like L</sv_derived_from_pv>, but doesn't take a C<flags> parameter. 156 157 =cut 158 */ 159 160 bool 161 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name) 162 { 163 PERL_ARGS_ASSERT_SV_DERIVED_FROM; 164 return sv_derived_from_svpvn(sv, NULL, name, strlen(name), 0); 165 } 166 167 /* 168 =for apidoc sv_derived_from_pv 169 170 Exactly like L</sv_derived_from_pvn>, but takes a nul-terminated string 171 instead of a string/length pair. 172 173 =cut 174 */ 175 176 177 bool 178 Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags) 179 { 180 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV; 181 return sv_derived_from_svpvn(sv, NULL, name, strlen(name), flags); 182 } 183 184 bool 185 Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags) 186 { 187 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN; 188 return sv_derived_from_svpvn(sv, NULL, name, len, flags); 189 } 190 191 /* 192 =for apidoc sv_isa_sv 193 194 Returns a boolean indicating whether the SV is an object reference and is 195 derived from the specified class, respecting any C<isa()> method overloading 196 it may have. Returns false if C<sv> is not a reference to an object, or is 197 not derived from the specified class. 198 199 This is the function used to implement the behaviour of the C<isa> operator. 200 201 Does not invoke magic on C<sv>. 202 203 Not to be confused with the older C<sv_isa> function, which does not use an 204 overloaded C<isa()> method, nor will check subclassing. 205 206 =cut 207 208 */ 209 210 bool 211 Perl_sv_isa_sv(pTHX_ SV *sv, SV *namesv) 212 { 213 GV *isagv; 214 215 PERL_ARGS_ASSERT_SV_ISA_SV; 216 217 if(!SvROK(sv) || !SvOBJECT(SvRV(sv))) 218 return FALSE; 219 220 isagv = gv_fetchmeth_pvn(SvSTASH(SvRV(sv)), "isa", 3, -1, GV_NOUNIVERSAL); 221 if(isagv) { 222 dSP; 223 CV *isacv = isGV(isagv) ? GvCV(isagv) : (CV *)isagv; 224 SV *retsv; 225 bool ret; 226 227 PUTBACK; 228 229 ENTER; 230 SAVETMPS; 231 232 EXTEND(SP, 2); 233 PUSHMARK(SP); 234 PUSHs(sv); 235 PUSHs(namesv); 236 PUTBACK; 237 238 call_sv((SV *)isacv, G_SCALAR); 239 240 SPAGAIN; 241 retsv = POPs; 242 ret = SvTRUE(retsv); 243 PUTBACK; 244 245 FREETMPS; 246 LEAVE; 247 248 return ret; 249 } 250 251 /* TODO: Support namesv being an HV ref to the stash directly? */ 252 253 return sv_derived_from_sv(sv, namesv, 0); 254 } 255 256 /* 257 =for apidoc sv_does_sv 258 259 Returns a boolean indicating whether the SV performs a specific, named role. 260 The SV can be a Perl object or the name of a Perl class. 261 262 =cut 263 */ 264 265 #include "XSUB.h" 266 267 bool 268 Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags) 269 { 270 SV *classname; 271 bool does_it; 272 SV *methodname; 273 dSP; 274 275 PERL_ARGS_ASSERT_SV_DOES_SV; 276 PERL_UNUSED_ARG(flags); 277 278 ENTER; 279 SAVETMPS; 280 281 SvGETMAGIC(sv); 282 283 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) { 284 LEAVE; 285 return FALSE; 286 } 287 288 if (SvROK(sv) && SvOBJECT(SvRV(sv))) { 289 classname = sv_ref(NULL,SvRV(sv),TRUE); 290 } else { 291 classname = sv; 292 } 293 294 if (sv_eq(classname, namesv)) { 295 LEAVE; 296 return TRUE; 297 } 298 299 PUSHMARK(SP); 300 EXTEND(SP, 2); 301 PUSHs(sv); 302 PUSHs(namesv); 303 PUTBACK; 304 305 /* create a PV with value "isa", but with a special address 306 * so that perl knows we're really doing "DOES" instead */ 307 methodname = newSV_type_mortal(SVt_PV); 308 SvLEN_set(methodname, 0); 309 SvCUR_set(methodname, strlen(PL_isa_DOES)); 310 SvPVX(methodname) = (char *)PL_isa_DOES; /* discard 'const' qualifier */ 311 SvPOK_on(methodname); 312 call_sv(methodname, G_SCALAR | G_METHOD); 313 SPAGAIN; 314 315 does_it = SvTRUE_NN( TOPs ); 316 FREETMPS; 317 LEAVE; 318 319 return does_it; 320 } 321 322 /* 323 =for apidoc sv_does 324 325 Like L</sv_does_pv>, but doesn't take a C<flags> parameter. 326 327 =cut 328 */ 329 330 bool 331 Perl_sv_does(pTHX_ SV *sv, const char *const name) 332 { 333 PERL_ARGS_ASSERT_SV_DOES; 334 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0); 335 } 336 337 /* 338 =for apidoc sv_does_pv 339 340 Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV. 341 342 =cut 343 */ 344 345 346 bool 347 Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags) 348 { 349 PERL_ARGS_ASSERT_SV_DOES_PV; 350 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags); 351 } 352 353 /* 354 =for apidoc sv_does_pvn 355 356 Like L</sv_does_sv>, but takes a string/length pair instead of an SV. 357 358 =cut 359 */ 360 361 bool 362 Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags) 363 { 364 PERL_ARGS_ASSERT_SV_DOES_PVN; 365 366 return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags); 367 } 368 369 /* 370 =for apidoc croak_xs_usage 371 372 A specialised variant of C<croak()> for emitting the usage message for xsubs 373 374 croak_xs_usage(cv, "eee_yow"); 375 376 works out the package name and subroutine name from C<cv>, and then calls 377 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as: 378 379 Perl_croak(aTHX_ "Usage: %" SVf "::%" SVf "(%s)", "ouch" "awk", 380 "eee_yow"); 381 382 =cut 383 */ 384 385 void 386 Perl_croak_xs_usage(const CV *const cv, const char *const params) 387 { 388 /* Avoid CvGV as it requires aTHX. */ 389 const GV *gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv; 390 391 PERL_ARGS_ASSERT_CROAK_XS_USAGE; 392 393 if (gv) got_gv: { 394 const HV *const stash = GvSTASH(gv); 395 396 if (HvNAME_get(stash)) 397 /* diag_listed_as: SKIPME */ 398 Perl_croak_nocontext("Usage: %" HEKf "::%" HEKf "(%s)", 399 HEKfARG(HvNAME_HEK(stash)), 400 HEKfARG(GvNAME_HEK(gv)), 401 params); 402 else 403 /* diag_listed_as: SKIPME */ 404 Perl_croak_nocontext("Usage: %" HEKf "(%s)", 405 HEKfARG(GvNAME_HEK(gv)), params); 406 } else { 407 dTHX; 408 if ((gv = CvGV(cv))) goto got_gv; 409 410 /* Pants. I don't think that it should be possible to get here. */ 411 /* diag_listed_as: SKIPME */ 412 Perl_croak(aTHX_ "Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params); 413 } 414 } 415 416 XS(XS_UNIVERSAL_isa); /* prototype to pass -Wmissing-prototypes */ 417 XS(XS_UNIVERSAL_isa) 418 { 419 dXSARGS; 420 421 if (items != 2) 422 croak_xs_usage(cv, "reference, kind"); 423 else { 424 SV * const sv = ST(0); 425 426 SvGETMAGIC(sv); 427 428 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) 429 XSRETURN_UNDEF; 430 431 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0)); 432 XSRETURN(1); 433 } 434 } 435 436 XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */ 437 XS(XS_UNIVERSAL_can) 438 { 439 dXSARGS; 440 SV *sv; 441 SV *rv; 442 HV *pkg = NULL; 443 GV *iogv; 444 445 if (items != 2) 446 croak_xs_usage(cv, "object-ref, method"); 447 448 sv = ST(0); 449 450 SvGETMAGIC(sv); 451 452 /* Reject undef and empty string. Note that the string form takes 453 precedence here over the numeric form, as (!1)->foo treats the 454 invocant as the empty string, though it is a dualvar. */ 455 if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv))) 456 XSRETURN_UNDEF; 457 458 rv = &PL_sv_undef; 459 460 if (SvROK(sv)) { 461 sv = MUTABLE_SV(SvRV(sv)); 462 if (SvOBJECT(sv)) 463 pkg = SvSTASH(sv); 464 else if (isGV_with_GP(sv) && GvIO(sv)) 465 pkg = SvSTASH(GvIO(sv)); 466 } 467 else if (isGV_with_GP(sv) && GvIO(sv)) 468 pkg = SvSTASH(GvIO(sv)); 469 else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv)) 470 pkg = SvSTASH(GvIO(iogv)); 471 else { 472 pkg = gv_stashsv(sv, 0); 473 if (!pkg) 474 pkg = gv_stashpvs("UNIVERSAL", 0); 475 } 476 477 if (pkg) { 478 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0); 479 if (gv && isGV(gv)) 480 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv)))); 481 } 482 483 ST(0) = rv; 484 XSRETURN(1); 485 } 486 487 XS(XS_UNIVERSAL_DOES); /* prototype to pass -Wmissing-prototypes */ 488 XS(XS_UNIVERSAL_DOES) 489 { 490 dXSARGS; 491 PERL_UNUSED_ARG(cv); 492 493 if (items != 2) 494 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)"); 495 else { 496 SV * const sv = ST(0); 497 if (sv_does_sv( sv, ST(1), 0 )) 498 XSRETURN_YES; 499 500 XSRETURN_NO; 501 } 502 } 503 504 XS(XS_utf8_is_utf8); /* prototype to pass -Wmissing-prototypes */ 505 XS(XS_utf8_is_utf8) 506 { 507 dXSARGS; 508 if (items != 1) 509 croak_xs_usage(cv, "sv"); 510 else { 511 SV * const sv = ST(0); 512 SvGETMAGIC(sv); 513 if (SvUTF8(sv)) 514 XSRETURN_YES; 515 else 516 XSRETURN_NO; 517 } 518 XSRETURN_EMPTY; 519 } 520 521 XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */ 522 XS(XS_utf8_valid) 523 { 524 dXSARGS; 525 if (items != 1) 526 croak_xs_usage(cv, "sv"); 527 else { 528 SV * const sv = ST(0); 529 STRLEN len; 530 const char * const s = SvPV_const(sv,len); 531 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len)) 532 XSRETURN_YES; 533 else 534 XSRETURN_NO; 535 } 536 XSRETURN_EMPTY; 537 } 538 539 XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */ 540 XS(XS_utf8_encode) 541 { 542 dXSARGS; 543 if (items != 1) 544 croak_xs_usage(cv, "sv"); 545 sv_utf8_encode(ST(0)); 546 SvSETMAGIC(ST(0)); 547 XSRETURN_EMPTY; 548 } 549 550 XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */ 551 XS(XS_utf8_decode) 552 { 553 dXSARGS; 554 if (items != 1) 555 croak_xs_usage(cv, "sv"); 556 else { 557 SV * const sv = ST(0); 558 bool RETVAL; 559 SvPV_force_nolen(sv); 560 RETVAL = sv_utf8_decode(sv); 561 SvSETMAGIC(sv); 562 ST(0) = boolSV(RETVAL); 563 } 564 XSRETURN(1); 565 } 566 567 XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */ 568 XS(XS_utf8_upgrade) 569 { 570 dXSARGS; 571 if (items != 1) 572 croak_xs_usage(cv, "sv"); 573 else { 574 SV * const sv = ST(0); 575 STRLEN RETVAL; 576 dXSTARG; 577 578 RETVAL = sv_utf8_upgrade(sv); 579 XSprePUSH; PUSHi((IV)RETVAL); 580 } 581 XSRETURN(1); 582 } 583 584 XS(XS_utf8_downgrade); /* prototype to pass -Wmissing-prototypes */ 585 XS(XS_utf8_downgrade) 586 { 587 dXSARGS; 588 if (items < 1 || items > 2) 589 croak_xs_usage(cv, "sv, failok=0"); 590 else { 591 SV * const sv0 = ST(0); 592 SV * const sv1 = ST(1); 593 const bool failok = (items < 2) ? 0 : SvTRUE_NN(sv1) ? 1 : 0; 594 const bool RETVAL = sv_utf8_downgrade(sv0, failok); 595 596 ST(0) = boolSV(RETVAL); 597 } 598 XSRETURN(1); 599 } 600 601 XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */ 602 XS(XS_utf8_native_to_unicode) 603 { 604 dXSARGS; 605 const UV uv = SvUV(ST(0)); 606 607 if (items > 1) 608 croak_xs_usage(cv, "sv"); 609 610 ST(0) = sv_2mortal(newSVuv(NATIVE_TO_UNI(uv))); 611 XSRETURN(1); 612 } 613 614 XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */ 615 XS(XS_utf8_unicode_to_native) 616 { 617 dXSARGS; 618 const UV uv = SvUV(ST(0)); 619 620 if (items > 1) 621 croak_xs_usage(cv, "sv"); 622 623 ST(0) = sv_2mortal(newSVuv(UNI_TO_NATIVE(uv))); 624 XSRETURN(1); 625 } 626 627 XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */ 628 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ 629 { 630 dXSARGS; 631 SV * const svz = ST(0); 632 SV * sv; 633 634 /* [perl #77776] - called as &foo() not foo() */ 635 if (!SvROK(svz)) 636 croak_xs_usage(cv, "SCALAR[, ON]"); 637 638 sv = SvRV(svz); 639 640 if (items == 1) { 641 if (SvREADONLY(sv)) 642 XSRETURN_YES; 643 else 644 XSRETURN_NO; 645 } 646 else if (items == 2) { 647 SV *sv1 = ST(1); 648 if (SvTRUE_NN(sv1)) { 649 SvFLAGS(sv) |= SVf_READONLY; 650 XSRETURN_YES; 651 } 652 else { 653 /* I hope you really know what you are doing. */ 654 SvFLAGS(sv) &=~ SVf_READONLY; 655 XSRETURN_NO; 656 } 657 } 658 XSRETURN_UNDEF; /* Can't happen. */ 659 } 660 661 XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */ 662 XS(XS_constant__make_const) /* This is dangerous stuff. */ 663 { 664 dXSARGS; 665 SV * const svz = ST(0); 666 SV * sv; 667 668 /* [perl #77776] - called as &foo() not foo() */ 669 if (!SvROK(svz) || items != 1) 670 croak_xs_usage(cv, "SCALAR"); 671 672 sv = SvRV(svz); 673 674 SvREADONLY_on(sv); 675 if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) { 676 /* for constant.pm; nobody else should be calling this 677 on arrays anyway. */ 678 SV **svp; 679 for (svp = AvARRAY(sv) + AvFILLp(sv) 680 ; svp >= AvARRAY(sv) 681 ; --svp) 682 if (*svp) SvPADTMP_on(*svp); 683 } 684 XSRETURN(0); 685 } 686 687 XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */ 688 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ 689 { 690 dXSARGS; 691 SV * const svz = ST(0); 692 SV * sv; 693 U32 refcnt; 694 695 /* [perl #77776] - called as &foo() not foo() */ 696 if ((items != 1 && items != 2) || !SvROK(svz)) 697 croak_xs_usage(cv, "SCALAR[, REFCOUNT]"); 698 699 sv = SvRV(svz); 700 701 /* I hope you really know what you are doing. */ 702 /* idea is for SvREFCNT(sv) to be accessed only once */ 703 refcnt = items == 2 ? 704 /* we free one ref on exit */ 705 (SvREFCNT(sv) = SvUV(ST(1)) + 1) 706 : SvREFCNT(sv); 707 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */ 708 709 } 710 711 XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */ 712 XS(XS_Internals_hv_clear_placehold) 713 { 714 dXSARGS; 715 716 if (items != 1 || !SvROK(ST(0))) 717 croak_xs_usage(cv, "hv"); 718 else { 719 HV * const hv = MUTABLE_HV(SvRV(ST(0))); 720 hv_clear_placeholders(hv); 721 XSRETURN(0); 722 } 723 } 724 725 XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */ 726 XS(XS_PerlIO_get_layers) 727 { 728 dXSARGS; 729 if (items < 1 || items % 2 == 0) 730 croak_xs_usage(cv, "filehandle[,args]"); 731 #if defined(USE_PERLIO) 732 { 733 SV * sv; 734 GV * gv; 735 IO * io; 736 bool input = TRUE; 737 bool details = FALSE; 738 739 if (items > 1) { 740 SV * const *svp; 741 for (svp = MARK + 2; svp <= SP; svp += 2) { 742 SV * const * const varp = svp; 743 SV * const * const valp = svp + 1; 744 STRLEN klen; 745 const char * const key = SvPV_const(*varp, klen); 746 747 switch (*key) { 748 case 'i': 749 if (memEQs(key, klen, "input")) { 750 input = SvTRUE(*valp); 751 break; 752 } 753 goto fail; 754 case 'o': 755 if (memEQs(key, klen, "output")) { 756 input = !SvTRUE(*valp); 757 break; 758 } 759 goto fail; 760 case 'd': 761 if (memEQs(key, klen, "details")) { 762 details = SvTRUE(*valp); 763 break; 764 } 765 goto fail; 766 default: 767 fail: 768 Perl_croak(aTHX_ 769 "get_layers: unknown argument '%s'", 770 key); 771 } 772 } 773 774 SP -= (items - 1); 775 } 776 777 sv = POPs; 778 gv = MAYBE_DEREF_GV(sv); 779 780 if (!gv && !SvROK(sv)) 781 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO); 782 783 if (gv && (io = GvIO(gv))) { 784 AV* const av = PerlIO_get_layers(aTHX_ input ? 785 IoIFP(io) : IoOFP(io)); 786 SSize_t i; 787 const SSize_t last = av_top_index(av); 788 SSize_t nitem = 0; 789 790 for (i = last; i >= 0; i -= 3) { 791 SV * const * const namsvp = av_fetch(av, i - 2, FALSE); 792 SV * const * const argsvp = av_fetch(av, i - 1, FALSE); 793 SV * const * const flgsvp = av_fetch(av, i, FALSE); 794 795 const bool namok = namsvp && *namsvp && SvPOK(*namsvp); 796 const bool argok = argsvp && *argsvp && SvPOK(*argsvp); 797 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp); 798 799 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */ 800 if (details) { 801 /* Indents of 5? Yuck. */ 802 /* We know that PerlIO_get_layers creates a new SV for 803 the name and flags, so we can just take a reference 804 and "steal" it when we free the AV below. */ 805 PUSHs(namok 806 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)) 807 : &PL_sv_undef); 808 PUSHs(argok 809 ? newSVpvn_flags(SvPVX_const(*argsvp), 810 SvCUR(*argsvp), 811 (SvUTF8(*argsvp) ? SVf_UTF8 : 0) 812 | SVs_TEMP) 813 : &PL_sv_undef); 814 PUSHs(flgok 815 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp)) 816 : &PL_sv_undef); 817 nitem += 3; 818 } 819 else { 820 if (namok && argok) 821 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%" SVf "(%" SVf ")", 822 SVfARG(*namsvp), 823 SVfARG(*argsvp)))); 824 else if (namok) 825 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))); 826 else 827 PUSHs(&PL_sv_undef); 828 nitem++; 829 if (flgok) { 830 const IV flags = SvIVX(*flgsvp); 831 832 if (flags & PERLIO_F_UTF8) { 833 PUSHs(newSVpvs_flags("utf8", SVs_TEMP)); 834 nitem++; 835 } 836 } 837 } 838 } 839 840 SvREFCNT_dec(av); 841 842 XSRETURN(nitem); 843 } 844 } 845 #endif 846 847 XSRETURN(0); 848 } 849 850 XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */ 851 XS(XS_re_is_regexp) 852 { 853 dXSARGS; 854 855 if (items != 1) 856 croak_xs_usage(cv, "sv"); 857 858 if (SvRXOK(ST(0))) { 859 XSRETURN_YES; 860 } else { 861 XSRETURN_NO; 862 } 863 } 864 865 XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */ 866 XS(XS_re_regnames_count) 867 { 868 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 869 SV * ret; 870 dXSARGS; 871 872 if (items != 0) 873 croak_xs_usage(cv, ""); 874 875 if (!rx) 876 XSRETURN_UNDEF; 877 878 ret = CALLREG_NAMED_BUFF_COUNT(rx); 879 880 SPAGAIN; 881 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); 882 XSRETURN(1); 883 } 884 885 XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */ 886 XS(XS_re_regname) 887 { 888 dXSARGS; 889 REGEXP * rx; 890 U32 flags; 891 SV * ret; 892 893 if (items < 1 || items > 2) 894 croak_xs_usage(cv, "name[, all ]"); 895 896 SP -= items; 897 PUTBACK; 898 899 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 900 901 if (!rx) 902 XSRETURN_UNDEF; 903 904 if (items == 2 && SvTRUE_NN(ST(1))) { 905 flags = RXapif_ALL; 906 } else { 907 flags = RXapif_ONE; 908 } 909 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME)); 910 911 SPAGAIN; 912 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); 913 XSRETURN(1); 914 } 915 916 917 XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */ 918 XS(XS_re_regnames) 919 { 920 dXSARGS; 921 REGEXP * rx; 922 U32 flags; 923 SV *ret; 924 AV *av; 925 SSize_t length; 926 SSize_t i; 927 SV **entry; 928 929 if (items > 1) 930 croak_xs_usage(cv, "[all]"); 931 932 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 933 934 if (!rx) 935 XSRETURN_UNDEF; 936 937 if (items == 1 && SvTRUE_NN(ST(0))) { 938 flags = RXapif_ALL; 939 } else { 940 flags = RXapif_ONE; 941 } 942 943 SP -= items; 944 PUTBACK; 945 946 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES)); 947 948 SPAGAIN; 949 950 if (!ret) 951 XSRETURN_UNDEF; 952 953 av = MUTABLE_AV(SvRV(ret)); 954 length = av_count(av); 955 956 EXTEND(SP, length); /* better extend stack just once */ 957 for (i = 0; i < length; i++) { 958 entry = av_fetch(av, i, FALSE); 959 960 if (!entry) 961 Perl_croak(aTHX_ "NULL array element in re::regnames()"); 962 963 mPUSHs(SvREFCNT_inc_simple_NN(*entry)); 964 } 965 966 SvREFCNT_dec(ret); 967 968 PUTBACK; 969 return; 970 } 971 972 XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */ 973 XS(XS_re_regexp_pattern) 974 { 975 dXSARGS; 976 REGEXP *re; 977 U8 const gimme = GIMME_V; 978 979 EXTEND(SP, 2); 980 SP -= items; 981 if (items != 1) 982 croak_xs_usage(cv, "sv"); 983 984 /* 985 Checks if a reference is a regex or not. If the parameter is 986 not a ref, or is not the result of a qr// then returns false 987 in scalar context and an empty list in list context. 988 Otherwise in list context it returns the pattern and the 989 modifiers, in scalar context it returns the pattern just as it 990 would if the qr// was stringified normally, regardless as 991 to the class of the variable and any stringification overloads 992 on the object. 993 */ 994 995 if ((re = SvRX(ST(0)))) /* assign deliberate */ 996 { 997 /* Houston, we have a regex! */ 998 SV *pattern; 999 1000 if ( gimme == G_LIST ) { 1001 STRLEN left = 0; 1002 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH]; 1003 const char *fptr; 1004 char ch; 1005 U16 match_flags; 1006 1007 /* 1008 we are in list context so stringify 1009 the modifiers that apply. We ignore "negative 1010 modifiers" in this scenario, and the default character set 1011 */ 1012 1013 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) { 1014 STRLEN len; 1015 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re), 1016 &len); 1017 Copy(name, reflags + left, len, char); 1018 left += len; 1019 } 1020 fptr = INT_PAT_MODS; 1021 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME) 1022 >> RXf_PMf_STD_PMMOD_SHIFT); 1023 1024 while((ch = *fptr++)) { 1025 if(match_flags & 1) { 1026 reflags[left++] = ch; 1027 } 1028 match_flags >>= 1; 1029 } 1030 1031 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re), 1032 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP); 1033 1034 /* return the pattern and the modifiers */ 1035 PUSHs(pattern); 1036 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP)); 1037 XSRETURN(2); 1038 } else { 1039 /* Scalar, so use the string that Perl would return */ 1040 /* return the pattern in (?msixn:..) format */ 1041 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re))); 1042 PUSHs(pattern); 1043 XSRETURN(1); 1044 } 1045 } else { 1046 /* It ain't a regexp folks */ 1047 if ( gimme == G_LIST ) { 1048 /* return the empty list */ 1049 XSRETURN_EMPTY; 1050 } else { 1051 /* Because of the (?:..) wrapping involved in a 1052 stringified pattern it is impossible to get a 1053 result for a real regexp that would evaluate to 1054 false. Therefore we can return PL_sv_no to signify 1055 that the object is not a regex, this means that one 1056 can say 1057 1058 if (regex($might_be_a_regex) eq '(?:foo)') { } 1059 1060 and not worry about undefined values. 1061 */ 1062 XSRETURN_NO; 1063 } 1064 } 1065 NOT_REACHED; /* NOTREACHED */ 1066 } 1067 1068 #if defined(HAS_GETCWD) && defined(PERL_IS_MINIPERL) 1069 1070 XS(XS_Internals_getcwd) 1071 { 1072 dXSARGS; 1073 SV *sv = sv_newmortal(); 1074 1075 if (items != 0) 1076 croak_xs_usage(cv, ""); 1077 1078 (void)getcwd_sv(sv); 1079 1080 SvTAINTED_on(sv); 1081 PUSHs(sv); 1082 XSRETURN(1); 1083 } 1084 1085 #endif 1086 1087 XS(XS_NamedCapture_tie_it) 1088 { 1089 dXSARGS; 1090 1091 if (items != 1) 1092 croak_xs_usage(cv, "sv"); 1093 { 1094 SV *sv = ST(0); 1095 GV * const gv = (GV *)sv; 1096 HV * const hv = GvHVn(gv); 1097 SV *rv = newSV_type(SVt_IV); 1098 const char *gv_name = GvNAME(gv); 1099 1100 sv_setrv_noinc(rv, newSVuv( 1101 strEQ(gv_name, "-") || strEQ(gv_name, "\003APTURE_ALL") 1102 ? RXapif_ALL : RXapif_ONE)); 1103 sv_bless(rv, GvSTASH(CvGV(cv))); 1104 1105 sv_unmagic((SV *)hv, PERL_MAGIC_tied); 1106 sv_magic((SV *)hv, rv, PERL_MAGIC_tied, NULL, 0); 1107 SvREFCNT_dec(rv); /* As sv_magic increased it by one. */ 1108 } 1109 XSRETURN_EMPTY; 1110 } 1111 1112 XS(XS_NamedCapture_TIEHASH) 1113 { 1114 dXSARGS; 1115 if (items < 1) 1116 croak_xs_usage(cv, "package, ..."); 1117 { 1118 const char * package = (const char *)SvPV_nolen(ST(0)); 1119 UV flag = RXapif_ONE; 1120 mark += 2; 1121 while(mark < sp) { 1122 STRLEN len; 1123 const char *p = SvPV_const(*mark, len); 1124 if(memEQs(p, len, "all")) 1125 flag = SvTRUE(mark[1]) ? RXapif_ALL : RXapif_ONE; 1126 mark += 2; 1127 } 1128 ST(0) = newSV_type_mortal(SVt_IV); 1129 sv_setuv(newSVrv(ST(0), package), flag); 1130 } 1131 XSRETURN(1); 1132 } 1133 1134 /* These are tightly coupled to the RXapif_* flags defined in regexp.h */ 1135 #define UNDEF_FATAL 0x80000 1136 #define DISCARD 0x40000 1137 #define EXPECT_SHIFT 24 1138 #define ACTION_MASK 0x000FF 1139 1140 #define FETCH_ALIAS (RXapif_FETCH | (2 << EXPECT_SHIFT)) 1141 #define STORE_ALIAS (RXapif_STORE | (3 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD) 1142 #define DELETE_ALIAS (RXapif_DELETE | (2 << EXPECT_SHIFT) | UNDEF_FATAL) 1143 #define CLEAR_ALIAS (RXapif_CLEAR | (1 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD) 1144 #define EXISTS_ALIAS (RXapif_EXISTS | (2 << EXPECT_SHIFT)) 1145 #define SCALAR_ALIAS (RXapif_SCALAR | (1 << EXPECT_SHIFT)) 1146 1147 XS(XS_NamedCapture_FETCH) 1148 { 1149 dXSARGS; 1150 dXSI32; 1151 PERL_UNUSED_VAR(cv); /* -W */ 1152 PERL_UNUSED_VAR(ax); /* -Wall */ 1153 SP -= items; 1154 { 1155 REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 1156 U32 flags; 1157 SV *ret; 1158 const U32 action = ix & ACTION_MASK; 1159 const int expect = ix >> EXPECT_SHIFT; 1160 if (items != expect) 1161 croak_xs_usage(cv, expect == 2 ? "$key" 1162 : (expect == 3 ? "$key, $value" 1163 : "")); 1164 1165 if (!rx || !SvROK(ST(0))) { 1166 if (ix & UNDEF_FATAL) 1167 Perl_croak_no_modify(); 1168 else 1169 XSRETURN_UNDEF; 1170 } 1171 1172 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); 1173 1174 PUTBACK; 1175 ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL, 1176 expect >= 3 ? ST(2) : NULL, flags | action); 1177 SPAGAIN; 1178 1179 if (ix & DISCARD) { 1180 /* Called with G_DISCARD, so our return stack state is thrown away. 1181 Hence if we were returned anything, free it immediately. */ 1182 SvREFCNT_dec(ret); 1183 } else { 1184 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); 1185 } 1186 PUTBACK; 1187 return; 1188 } 1189 } 1190 1191 1192 XS(XS_NamedCapture_FIRSTKEY) 1193 { 1194 dXSARGS; 1195 dXSI32; 1196 PERL_UNUSED_VAR(cv); /* -W */ 1197 PERL_UNUSED_VAR(ax); /* -Wall */ 1198 SP -= items; 1199 { 1200 REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 1201 U32 flags; 1202 SV *ret; 1203 const int expect = ix ? 2 : 1; 1204 const U32 action = ix ? RXapif_NEXTKEY : RXapif_FIRSTKEY; 1205 if (items != expect) 1206 croak_xs_usage(cv, expect == 2 ? "$lastkey" : ""); 1207 1208 if (!rx || !SvROK(ST(0))) 1209 XSRETURN_UNDEF; 1210 1211 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); 1212 1213 PUTBACK; 1214 ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx), 1215 expect >= 2 ? ST(1) : NULL, 1216 flags | action); 1217 SPAGAIN; 1218 1219 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); 1220 PUTBACK; 1221 return; 1222 } 1223 } 1224 1225 /* is this still needed? */ 1226 XS(XS_NamedCapture_flags) 1227 { 1228 dXSARGS; 1229 PERL_UNUSED_VAR(cv); /* -W */ 1230 PERL_UNUSED_VAR(ax); /* -Wall */ 1231 SP -= items; 1232 { 1233 EXTEND(SP, 2); 1234 mPUSHu(RXapif_ONE); 1235 mPUSHu(RXapif_ALL); 1236 PUTBACK; 1237 return; 1238 } 1239 } 1240 1241 #include "vutil.h" 1242 #include "vxs.inc" 1243 1244 struct xsub_details { 1245 const char *name; 1246 XSUBADDR_t xsub; 1247 const char *proto; 1248 int ix; 1249 }; 1250 1251 static const struct xsub_details these_details[] = { 1252 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL, 0 }, 1253 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL, 0 }, 1254 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL, 0 }, 1255 #define VXS_XSUB_DETAILS 1256 #include "vxs.inc" 1257 #undef VXS_XSUB_DETAILS 1258 {"utf8::is_utf8", XS_utf8_is_utf8, NULL, 0 }, 1259 {"utf8::valid", XS_utf8_valid, NULL, 0 }, 1260 {"utf8::encode", XS_utf8_encode, NULL, 0 }, 1261 {"utf8::decode", XS_utf8_decode, NULL, 0 }, 1262 {"utf8::upgrade", XS_utf8_upgrade, NULL, 0 }, 1263 {"utf8::downgrade", XS_utf8_downgrade, NULL, 0 }, 1264 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL, 0 }, 1265 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL, 0 }, 1266 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$", 0 }, 1267 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$", 0 }, 1268 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%", 0 }, 1269 {"constant::_make_const", XS_constant__make_const, "\\[$@]", 0 }, 1270 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@", 0 }, 1271 {"re::is_regexp", XS_re_is_regexp, "$", 0 }, 1272 {"re::regname", XS_re_regname, ";$$", 0 }, 1273 {"re::regnames", XS_re_regnames, ";$", 0 }, 1274 {"re::regnames_count", XS_re_regnames_count, "", 0 }, 1275 {"re::regexp_pattern", XS_re_regexp_pattern, "$", 0 }, 1276 #if defined(HAS_GETCWD) && defined(PERL_IS_MINIPERL) 1277 {"Internals::getcwd", XS_Internals_getcwd, "", 0 }, 1278 #endif 1279 {"Tie::Hash::NamedCapture::_tie_it", XS_NamedCapture_tie_it, NULL, 0 }, 1280 {"Tie::Hash::NamedCapture::TIEHASH", XS_NamedCapture_TIEHASH, NULL, 0 }, 1281 {"Tie::Hash::NamedCapture::FETCH", XS_NamedCapture_FETCH, NULL, FETCH_ALIAS }, 1282 {"Tie::Hash::NamedCapture::STORE", XS_NamedCapture_FETCH, NULL, STORE_ALIAS }, 1283 {"Tie::Hash::NamedCapture::DELETE", XS_NamedCapture_FETCH, NULL, DELETE_ALIAS }, 1284 {"Tie::Hash::NamedCapture::CLEAR", XS_NamedCapture_FETCH, NULL, CLEAR_ALIAS }, 1285 {"Tie::Hash::NamedCapture::EXISTS", XS_NamedCapture_FETCH, NULL, EXISTS_ALIAS }, 1286 {"Tie::Hash::NamedCapture::SCALAR", XS_NamedCapture_FETCH, NULL, SCALAR_ALIAS }, 1287 {"Tie::Hash::NamedCapture::FIRSTKEY", XS_NamedCapture_FIRSTKEY, NULL, 0 }, 1288 {"Tie::Hash::NamedCapture::NEXTKEY", XS_NamedCapture_FIRSTKEY, NULL, 1 }, 1289 {"Tie::Hash::NamedCapture::flags", XS_NamedCapture_flags, NULL, 0 }, 1290 }; 1291 1292 STATIC OP* 1293 optimize_out_native_convert_function(pTHX_ OP* entersubop, 1294 GV* namegv, 1295 SV* protosv) 1296 { 1297 /* Optimizes out an identity function, i.e., one that just returns its 1298 * argument. The passed in function is assumed to be an identity function, 1299 * with no checking. This is designed to be called for utf8_to_native() 1300 * and native_to_utf8() on ASCII platforms, as they just return their 1301 * arguments, but it could work on any such function. 1302 * 1303 * The code is mostly just cargo-culted from Memoize::Lift */ 1304 1305 OP *pushop, *argop; 1306 OP *parent; 1307 SV* prototype = newSVpvs("$"); 1308 1309 PERL_UNUSED_ARG(protosv); 1310 1311 assert(entersubop->op_type == OP_ENTERSUB); 1312 1313 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype); 1314 parent = entersubop; 1315 1316 SvREFCNT_dec(prototype); 1317 1318 pushop = cUNOPx(entersubop)->op_first; 1319 if (! OpHAS_SIBLING(pushop)) { 1320 parent = pushop; 1321 pushop = cUNOPx(pushop)->op_first; 1322 } 1323 argop = OpSIBLING(pushop); 1324 1325 /* Carry on without doing the optimization if it is not something we're 1326 * expecting, so continues to work */ 1327 if ( ! argop 1328 || ! OpHAS_SIBLING(argop) 1329 || OpHAS_SIBLING(OpSIBLING(argop)) 1330 ) { 1331 return entersubop; 1332 } 1333 1334 /* cut argop from the subtree */ 1335 (void)op_sibling_splice(parent, pushop, 1, NULL); 1336 1337 op_free(entersubop); 1338 return argop; 1339 } 1340 1341 void 1342 Perl_boot_core_UNIVERSAL(pTHX) 1343 { 1344 static const char file[] = __FILE__; 1345 const struct xsub_details *xsub = these_details; 1346 const struct xsub_details *end = C_ARRAY_END(these_details); 1347 1348 do { 1349 CV *cv = newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0); 1350 XSANY.any_i32 = xsub->ix; 1351 } while (++xsub < end); 1352 1353 #ifndef EBCDIC 1354 { /* On ASCII platforms these functions just return their argument, so can 1355 be optimized away */ 1356 1357 CV* to_native_cv = get_cv("utf8::unicode_to_native", 0); 1358 CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0); 1359 1360 cv_set_call_checker_flags(to_native_cv, 1361 optimize_out_native_convert_function, 1362 (SV*) to_native_cv, 0); 1363 cv_set_call_checker_flags(to_unicode_cv, 1364 optimize_out_native_convert_function, 1365 (SV*) to_unicode_cv, 0); 1366 } 1367 #endif 1368 1369 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */ 1370 { 1371 CV * const cv = 1372 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL); 1373 char ** cvfile = &CvFILE(cv); 1374 char * oldfile = *cvfile; 1375 CvDYNFILE_off(cv); 1376 *cvfile = (char *)file; 1377 Safefree(oldfile); 1378 } 1379 } 1380 1381 /* 1382 * ex: set ts=8 sts=4 sw=4 et: 1383 */ 1384