1 /* universal.c 2 * 3 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 4 * 2005, 2006, 2007, 2008 by Larry Wall and others 5 * 6 * You may distribute under the terms of either the GNU General Public 7 * License or the Artistic License, as specified in the README file. 8 * 9 */ 10 11 /* 12 * '"The roots of those mountains must be roots indeed; there must be 13 * great secrets buried there which have not been discovered since the 14 * beginning."' --Gandalf, relating Gollum's history 15 * 16 * [p.54 of _The Lord of the Rings_, I/ii: "The Shadow of the Past"] 17 */ 18 19 /* This file contains the code that implements the functions in Perl's 20 * UNIVERSAL package, such as UNIVERSAL->can(). 21 * 22 * It is also used to store XS functions that need to be present in 23 * miniperl for a lack of a better place to put them. It might be 24 * clever to move them to seperate XS files which would then be pulled 25 * in by some to-be-written build process. 26 */ 27 28 #include "EXTERN.h" 29 #define PERL_IN_UNIVERSAL_C 30 #include "perl.h" 31 32 #ifdef USE_PERLIO 33 #include "perliol.h" /* For the PERLIO_F_XXX */ 34 #endif 35 36 static HV * 37 S_get_isa_hash(pTHX_ HV *const stash) 38 { 39 dVAR; 40 struct mro_meta *const meta = HvMROMETA(stash); 41 42 PERL_ARGS_ASSERT_GET_ISA_HASH; 43 44 if (!meta->isa) { 45 AV *const isa = mro_get_linear_isa(stash); 46 if (!meta->isa) { 47 HV *const isa_hash = newHV(); 48 /* Linearisation didn't build it for us, so do it here. */ 49 SV *const *svp = AvARRAY(isa); 50 SV *const *const svp_end = svp + AvFILLp(isa) + 1; 51 const HEK *const canon_name = HvNAME_HEK(stash); 52 53 while (svp < svp_end) { 54 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0); 55 } 56 57 (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name), 58 HEK_LEN(canon_name), HEK_FLAGS(canon_name), 59 HV_FETCH_ISSTORE, &PL_sv_undef, 60 HEK_HASH(canon_name)); 61 (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0); 62 63 SvREADONLY_on(isa_hash); 64 65 meta->isa = isa_hash; 66 } 67 } 68 return meta->isa; 69 } 70 71 /* 72 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com> 73 * The main guts of traverse_isa was actually copied from gv_fetchmeth 74 */ 75 76 STATIC bool 77 S_isa_lookup(pTHX_ HV *stash, const char * const name) 78 { 79 dVAR; 80 const struct mro_meta *const meta = HvMROMETA(stash); 81 HV *const isa = meta->isa ? meta->isa : S_get_isa_hash(aTHX_ stash); 82 STRLEN len = strlen(name); 83 const HV *our_stash; 84 85 PERL_ARGS_ASSERT_ISA_LOOKUP; 86 87 if (hv_common(isa, NULL, name, len, 0 /* No "UTF-8" flag possible with only 88 a char * argument*/, 89 HV_FETCH_ISEXISTS, NULL, 0)) { 90 /* Direct name lookup worked. */ 91 return TRUE; 92 } 93 94 /* A stash/class can go by many names (ie. User == main::User), so 95 we use the name in the stash itself, which is canonical. */ 96 our_stash = gv_stashpvn(name, len, 0); 97 98 if (our_stash) { 99 HEK *const canon_name = HvNAME_HEK(our_stash); 100 101 if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name), 102 HEK_FLAGS(canon_name), 103 HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) { 104 return TRUE; 105 } 106 } 107 108 return FALSE; 109 } 110 111 /* 112 =head1 SV Manipulation Functions 113 114 =for apidoc sv_derived_from 115 116 Returns a boolean indicating whether the SV is derived from the specified class 117 I<at the C level>. To check derivation at the Perl level, call C<isa()> as a 118 normal Perl method. 119 120 =cut 121 */ 122 123 bool 124 Perl_sv_derived_from(pTHX_ SV *sv, const char *name) 125 { 126 dVAR; 127 HV *stash; 128 129 PERL_ARGS_ASSERT_SV_DERIVED_FROM; 130 131 SvGETMAGIC(sv); 132 133 if (SvROK(sv)) { 134 const char *type; 135 sv = SvRV(sv); 136 type = sv_reftype(sv,0); 137 if (type && strEQ(type,name)) 138 return TRUE; 139 stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL; 140 } 141 else { 142 stash = gv_stashsv(sv, 0); 143 } 144 145 return stash ? isa_lookup(stash, name) : FALSE; 146 } 147 148 /* 149 =for apidoc sv_does 150 151 Returns a boolean indicating whether the SV performs a specific, named role. 152 The SV can be a Perl object or the name of a Perl class. 153 154 =cut 155 */ 156 157 #include "XSUB.h" 158 159 bool 160 Perl_sv_does(pTHX_ SV *sv, const char *name) 161 { 162 const char *classname; 163 bool does_it; 164 SV *methodname; 165 dSP; 166 167 PERL_ARGS_ASSERT_SV_DOES; 168 169 ENTER; 170 SAVETMPS; 171 172 SvGETMAGIC(sv); 173 174 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) 175 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) 176 return FALSE; 177 178 if (sv_isobject(sv)) { 179 classname = sv_reftype(SvRV(sv),TRUE); 180 } else { 181 classname = SvPV_nolen(sv); 182 } 183 184 if (strEQ(name,classname)) 185 return TRUE; 186 187 PUSHMARK(SP); 188 XPUSHs(sv); 189 mXPUSHs(newSVpv(name, 0)); 190 PUTBACK; 191 192 methodname = newSVpvs_flags("isa", SVs_TEMP); 193 /* ugly hack: use the SvSCREAM flag so S_method_common 194 * can figure out we're calling DOES() and not isa(), 195 * and report eventual errors correctly. --rgs */ 196 SvSCREAM_on(methodname); 197 call_sv(methodname, G_SCALAR | G_METHOD); 198 SPAGAIN; 199 200 does_it = SvTRUE( TOPs ); 201 FREETMPS; 202 LEAVE; 203 204 return does_it; 205 } 206 207 PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv); 208 PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv); 209 PERL_XS_EXPORT_C void XS_UNIVERSAL_DOES(pTHX_ CV *cv); 210 PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv); 211 XS(XS_version_new); 212 XS(XS_version_stringify); 213 XS(XS_version_numify); 214 XS(XS_version_normal); 215 XS(XS_version_vcmp); 216 XS(XS_version_boolean); 217 #ifdef HASATTRIBUTE_NORETURN 218 XS(XS_version_noop) __attribute__noreturn__; 219 #else 220 XS(XS_version_noop); 221 #endif 222 XS(XS_version_is_alpha); 223 XS(XS_version_qv); 224 XS(XS_version_is_qv); 225 XS(XS_utf8_is_utf8); 226 XS(XS_utf8_valid); 227 XS(XS_utf8_encode); 228 XS(XS_utf8_decode); 229 XS(XS_utf8_upgrade); 230 XS(XS_utf8_downgrade); 231 XS(XS_utf8_unicode_to_native); 232 XS(XS_utf8_native_to_unicode); 233 XS(XS_Internals_SvREADONLY); 234 XS(XS_Internals_SvREFCNT); 235 XS(XS_Internals_hv_clear_placehold); 236 XS(XS_PerlIO_get_layers); 237 XS(XS_Regexp_DESTROY); 238 XS(XS_Internals_hash_seed); 239 XS(XS_Internals_rehash_seed); 240 XS(XS_Internals_HvREHASH); 241 XS(XS_re_is_regexp); 242 XS(XS_re_regname); 243 XS(XS_re_regnames); 244 XS(XS_re_regnames_count); 245 XS(XS_re_regexp_pattern); 246 XS(XS_Tie_Hash_NamedCapture_FETCH); 247 XS(XS_Tie_Hash_NamedCapture_STORE); 248 XS(XS_Tie_Hash_NamedCapture_DELETE); 249 XS(XS_Tie_Hash_NamedCapture_CLEAR); 250 XS(XS_Tie_Hash_NamedCapture_EXISTS); 251 XS(XS_Tie_Hash_NamedCapture_FIRSTK); 252 XS(XS_Tie_Hash_NamedCapture_NEXTK); 253 XS(XS_Tie_Hash_NamedCapture_SCALAR); 254 XS(XS_Tie_Hash_NamedCapture_flags); 255 256 void 257 Perl_boot_core_UNIVERSAL(pTHX) 258 { 259 dVAR; 260 static const char file[] = __FILE__; 261 262 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); 263 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); 264 newXS("UNIVERSAL::DOES", XS_UNIVERSAL_DOES, file); 265 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file); 266 { 267 /* register the overloading (type 'A') magic */ 268 PL_amagic_generation++; 269 /* Make it findable via fetchmethod */ 270 newXS("version::()", XS_version_noop, file); 271 newXS("version::new", XS_version_new, file); 272 newXS("version::parse", XS_version_new, file); 273 newXS("version::(\"\"", XS_version_stringify, file); 274 newXS("version::stringify", XS_version_stringify, file); 275 newXS("version::(0+", XS_version_numify, file); 276 newXS("version::numify", XS_version_numify, file); 277 newXS("version::normal", XS_version_normal, file); 278 newXS("version::(cmp", XS_version_vcmp, file); 279 newXS("version::(<=>", XS_version_vcmp, file); 280 newXS("version::vcmp", XS_version_vcmp, file); 281 newXS("version::(bool", XS_version_boolean, file); 282 newXS("version::boolean", XS_version_boolean, file); 283 newXS("version::(nomethod", XS_version_noop, file); 284 newXS("version::noop", XS_version_noop, file); 285 newXS("version::is_alpha", XS_version_is_alpha, file); 286 newXS("version::qv", XS_version_qv, file); 287 newXS("version::declare", XS_version_qv, file); 288 newXS("version::is_qv", XS_version_is_qv, file); 289 } 290 newXS("utf8::is_utf8", XS_utf8_is_utf8, file); 291 newXS("utf8::valid", XS_utf8_valid, file); 292 newXS("utf8::encode", XS_utf8_encode, file); 293 newXS("utf8::decode", XS_utf8_decode, file); 294 newXS("utf8::upgrade", XS_utf8_upgrade, file); 295 newXS("utf8::downgrade", XS_utf8_downgrade, file); 296 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file); 297 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file); 298 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$"); 299 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$"); 300 newXSproto("Internals::hv_clear_placeholders", 301 XS_Internals_hv_clear_placehold, file, "\\%"); 302 newXSproto("PerlIO::get_layers", 303 XS_PerlIO_get_layers, file, "*;@"); 304 newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file); 305 newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, ""); 306 newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, ""); 307 newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%"); 308 newXSproto("re::is_regexp", XS_re_is_regexp, file, "$"); 309 newXSproto("re::regname", XS_re_regname, file, ";$$"); 310 newXSproto("re::regnames", XS_re_regnames, file, ";$"); 311 newXSproto("re::regnames_count", XS_re_regnames_count, file, ""); 312 newXSproto("re::regexp_pattern", XS_re_regexp_pattern, file, "$"); 313 newXS("Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, file); 314 newXS("Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, file); 315 newXS("Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, file); 316 newXS("Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, file); 317 newXS("Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, file); 318 newXS("Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, file); 319 newXS("Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, file); 320 newXS("Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, file); 321 newXS("Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, file); 322 } 323 324 /* 325 =for apidoc croak_xs_usage 326 327 A specialised variant of C<croak()> for emitting the usage message for xsubs 328 329 croak_xs_usage(cv, "eee_yow"); 330 331 works out the package name and subroutine name from C<cv>, and then calls 332 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as: 333 334 Perl_croak(aTHX_ "Usage %s::%s(%s)", "ouch" "awk", "eee_yow"); 335 336 =cut 337 */ 338 339 void 340 Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) 341 { 342 const GV *const gv = CvGV(cv); 343 344 PERL_ARGS_ASSERT_CROAK_XS_USAGE; 345 346 if (gv) { 347 const char *const gvname = GvNAME(gv); 348 const HV *const stash = GvSTASH(gv); 349 const char *const hvname = stash ? HvNAME_get(stash) : NULL; 350 351 if (hvname) 352 Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params); 353 else 354 Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params); 355 } else { 356 /* Pants. I don't think that it should be possible to get here. */ 357 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); 358 } 359 } 360 361 XS(XS_UNIVERSAL_isa) 362 { 363 dVAR; 364 dXSARGS; 365 366 if (items != 2) 367 croak_xs_usage(cv, "reference, kind"); 368 else { 369 SV * const sv = ST(0); 370 const char *name; 371 372 SvGETMAGIC(sv); 373 374 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) 375 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) 376 XSRETURN_UNDEF; 377 378 name = SvPV_nolen_const(ST(1)); 379 380 ST(0) = boolSV(sv_derived_from(sv, name)); 381 XSRETURN(1); 382 } 383 } 384 385 XS(XS_UNIVERSAL_can) 386 { 387 dVAR; 388 dXSARGS; 389 SV *sv; 390 const char *name; 391 SV *rv; 392 HV *pkg = NULL; 393 394 if (items != 2) 395 croak_xs_usage(cv, "object-ref, method"); 396 397 sv = ST(0); 398 399 SvGETMAGIC(sv); 400 401 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) 402 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) 403 XSRETURN_UNDEF; 404 405 name = SvPV_nolen_const(ST(1)); 406 rv = &PL_sv_undef; 407 408 if (SvROK(sv)) { 409 sv = MUTABLE_SV(SvRV(sv)); 410 if (SvOBJECT(sv)) 411 pkg = SvSTASH(sv); 412 } 413 else { 414 pkg = gv_stashsv(sv, 0); 415 } 416 417 if (pkg) { 418 GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE); 419 if (gv && isGV(gv)) 420 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv)))); 421 } 422 423 ST(0) = rv; 424 XSRETURN(1); 425 } 426 427 XS(XS_UNIVERSAL_DOES) 428 { 429 dVAR; 430 dXSARGS; 431 PERL_UNUSED_ARG(cv); 432 433 if (items != 2) 434 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)"); 435 else { 436 SV * const sv = ST(0); 437 const char *name; 438 439 name = SvPV_nolen_const(ST(1)); 440 if (sv_does( sv, name )) 441 XSRETURN_YES; 442 443 XSRETURN_NO; 444 } 445 } 446 447 XS(XS_UNIVERSAL_VERSION) 448 { 449 dVAR; 450 dXSARGS; 451 HV *pkg; 452 GV **gvp; 453 GV *gv; 454 SV *sv; 455 const char *undef; 456 PERL_UNUSED_ARG(cv); 457 458 if (SvROK(ST(0))) { 459 sv = MUTABLE_SV(SvRV(ST(0))); 460 if (!SvOBJECT(sv)) 461 Perl_croak(aTHX_ "Cannot find version of an unblessed reference"); 462 pkg = SvSTASH(sv); 463 } 464 else { 465 pkg = gv_stashsv(ST(0), 0); 466 } 467 468 gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL; 469 470 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) { 471 SV * const nsv = sv_newmortal(); 472 sv_setsv(nsv, sv); 473 sv = nsv; 474 if ( !sv_derived_from(sv, "version")) 475 upg_version(sv, FALSE); 476 undef = NULL; 477 } 478 else { 479 sv = &PL_sv_undef; 480 undef = "(undef)"; 481 } 482 483 if (items > 1) { 484 SV *req = ST(1); 485 486 if (undef) { 487 if (pkg) { 488 const char * const name = HvNAME_get(pkg); 489 Perl_croak(aTHX_ 490 "%s does not define $%s::VERSION--version check failed", 491 name, name); 492 } else { 493 Perl_croak(aTHX_ 494 "%s defines neither package nor VERSION--version check failed", 495 SvPVx_nolen_const(ST(0)) ); 496 } 497 } 498 499 if ( !sv_derived_from(req, "version")) { 500 /* req may very well be R/O, so create a new object */ 501 req = sv_2mortal( new_version(req) ); 502 } 503 504 if ( vcmp( req, sv ) > 0 ) { 505 if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) { 506 Perl_croak(aTHX_ "%s version %"SVf" required--" 507 "this is only version %"SVf"", HvNAME_get(pkg), 508 SVfARG(vnormal(req)), 509 SVfARG(vnormal(sv))); 510 } else { 511 Perl_croak(aTHX_ "%s version %"SVf" required--" 512 "this is only version %"SVf"", HvNAME_get(pkg), 513 SVfARG(vstringify(req)), 514 SVfARG(vstringify(sv))); 515 } 516 } 517 518 } 519 520 if ( SvOK(sv) && sv_derived_from(sv, "version") ) { 521 ST(0) = vstringify(sv); 522 } else { 523 ST(0) = sv; 524 } 525 526 XSRETURN(1); 527 } 528 529 XS(XS_version_new) 530 { 531 dVAR; 532 dXSARGS; 533 if (items > 3) 534 croak_xs_usage(cv, "class, version"); 535 SP -= items; 536 { 537 SV *vs = ST(1); 538 SV *rv; 539 const char * const classname = 540 sv_isobject(ST(0)) /* get the class if called as an object method */ 541 ? HvNAME(SvSTASH(SvRV(ST(0)))) 542 : (char *)SvPV_nolen(ST(0)); 543 544 if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */ 545 /* create empty object */ 546 vs = sv_newmortal(); 547 sv_setpvs(vs,""); 548 } 549 else if ( items == 3 ) { 550 vs = sv_newmortal(); 551 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2))); 552 } 553 554 rv = new_version(vs); 555 if ( strcmp(classname,"version") != 0 ) /* inherited new() */ 556 sv_bless(rv, gv_stashpv(classname, GV_ADD)); 557 558 mPUSHs(rv); 559 PUTBACK; 560 return; 561 } 562 } 563 564 XS(XS_version_stringify) 565 { 566 dVAR; 567 dXSARGS; 568 if (items < 1) 569 croak_xs_usage(cv, "lobj, ..."); 570 SP -= items; 571 { 572 SV * lobj; 573 574 if (sv_derived_from(ST(0), "version")) { 575 lobj = SvRV(ST(0)); 576 } 577 else 578 Perl_croak(aTHX_ "lobj is not of type version"); 579 580 mPUSHs(vstringify(lobj)); 581 582 PUTBACK; 583 return; 584 } 585 } 586 587 XS(XS_version_numify) 588 { 589 dVAR; 590 dXSARGS; 591 if (items < 1) 592 croak_xs_usage(cv, "lobj, ..."); 593 SP -= items; 594 { 595 SV * lobj; 596 597 if (sv_derived_from(ST(0), "version")) { 598 lobj = SvRV(ST(0)); 599 } 600 else 601 Perl_croak(aTHX_ "lobj is not of type version"); 602 603 mPUSHs(vnumify(lobj)); 604 605 PUTBACK; 606 return; 607 } 608 } 609 610 XS(XS_version_normal) 611 { 612 dVAR; 613 dXSARGS; 614 if (items < 1) 615 croak_xs_usage(cv, "lobj, ..."); 616 SP -= items; 617 { 618 SV * lobj; 619 620 if (sv_derived_from(ST(0), "version")) { 621 lobj = SvRV(ST(0)); 622 } 623 else 624 Perl_croak(aTHX_ "lobj is not of type version"); 625 626 mPUSHs(vnormal(lobj)); 627 628 PUTBACK; 629 return; 630 } 631 } 632 633 XS(XS_version_vcmp) 634 { 635 dVAR; 636 dXSARGS; 637 if (items < 1) 638 croak_xs_usage(cv, "lobj, ..."); 639 SP -= items; 640 { 641 SV * lobj; 642 643 if (sv_derived_from(ST(0), "version")) { 644 lobj = SvRV(ST(0)); 645 } 646 else 647 Perl_croak(aTHX_ "lobj is not of type version"); 648 649 { 650 SV *rs; 651 SV *rvs; 652 SV * robj = ST(1); 653 const IV swap = (IV)SvIV(ST(2)); 654 655 if ( ! sv_derived_from(robj, "version") ) 656 { 657 robj = new_version(robj); 658 } 659 rvs = SvRV(robj); 660 661 if ( swap ) 662 { 663 rs = newSViv(vcmp(rvs,lobj)); 664 } 665 else 666 { 667 rs = newSViv(vcmp(lobj,rvs)); 668 } 669 670 mPUSHs(rs); 671 } 672 673 PUTBACK; 674 return; 675 } 676 } 677 678 XS(XS_version_boolean) 679 { 680 dVAR; 681 dXSARGS; 682 if (items < 1) 683 croak_xs_usage(cv, "lobj, ..."); 684 SP -= items; 685 if (sv_derived_from(ST(0), "version")) { 686 SV * const lobj = SvRV(ST(0)); 687 SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) ); 688 mPUSHs(rs); 689 PUTBACK; 690 return; 691 } 692 else 693 Perl_croak(aTHX_ "lobj is not of type version"); 694 } 695 696 XS(XS_version_noop) 697 { 698 dVAR; 699 dXSARGS; 700 if (items < 1) 701 croak_xs_usage(cv, "lobj, ..."); 702 if (sv_derived_from(ST(0), "version")) 703 Perl_croak(aTHX_ "operation not supported with version object"); 704 else 705 Perl_croak(aTHX_ "lobj is not of type version"); 706 #ifndef HASATTRIBUTE_NORETURN 707 XSRETURN_EMPTY; 708 #endif 709 } 710 711 XS(XS_version_is_alpha) 712 { 713 dVAR; 714 dXSARGS; 715 if (items != 1) 716 croak_xs_usage(cv, "lobj"); 717 SP -= items; 718 if (sv_derived_from(ST(0), "version")) { 719 SV * const lobj = ST(0); 720 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) ) 721 XSRETURN_YES; 722 else 723 XSRETURN_NO; 724 PUTBACK; 725 return; 726 } 727 else 728 Perl_croak(aTHX_ "lobj is not of type version"); 729 } 730 731 XS(XS_version_qv) 732 { 733 dVAR; 734 dXSARGS; 735 PERL_UNUSED_ARG(cv); 736 SP -= items; 737 { 738 SV * ver = ST(0); 739 SV * rv; 740 const char * classname = ""; 741 if ( items == 2 && (ST(1)) != &PL_sv_undef ) { 742 /* getting called as object or class method */ 743 ver = ST(1); 744 classname = 745 sv_isobject(ST(0)) /* class called as an object method */ 746 ? HvNAME_get(SvSTASH(SvRV(ST(0)))) 747 : (char *)SvPV_nolen(ST(0)); 748 } 749 if ( !SvVOK(ver) ) { /* not already a v-string */ 750 rv = sv_newmortal(); 751 sv_setsv(rv,ver); /* make a duplicate */ 752 upg_version(rv, TRUE); 753 } else { 754 rv = sv_2mortal(new_version(ver)); 755 } 756 if ( items == 2 && strcmp(classname,"version") ) { /* inherited new() */ 757 sv_bless(rv, gv_stashpv(classname, GV_ADD)); 758 } 759 PUSHs(rv); 760 } 761 PUTBACK; 762 return; 763 } 764 765 XS(XS_version_is_qv) 766 { 767 dVAR; 768 dXSARGS; 769 if (items != 1) 770 croak_xs_usage(cv, "lobj"); 771 SP -= items; 772 if (sv_derived_from(ST(0), "version")) { 773 SV * const lobj = ST(0); 774 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) ) 775 XSRETURN_YES; 776 else 777 XSRETURN_NO; 778 PUTBACK; 779 return; 780 } 781 else 782 Perl_croak(aTHX_ "lobj is not of type version"); 783 } 784 785 XS(XS_utf8_is_utf8) 786 { 787 dVAR; 788 dXSARGS; 789 if (items != 1) 790 croak_xs_usage(cv, "sv"); 791 else { 792 const SV * const sv = ST(0); 793 if (SvUTF8(sv)) 794 XSRETURN_YES; 795 else 796 XSRETURN_NO; 797 } 798 XSRETURN_EMPTY; 799 } 800 801 XS(XS_utf8_valid) 802 { 803 dVAR; 804 dXSARGS; 805 if (items != 1) 806 croak_xs_usage(cv, "sv"); 807 else { 808 SV * const sv = ST(0); 809 STRLEN len; 810 const char * const s = SvPV_const(sv,len); 811 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len)) 812 XSRETURN_YES; 813 else 814 XSRETURN_NO; 815 } 816 XSRETURN_EMPTY; 817 } 818 819 XS(XS_utf8_encode) 820 { 821 dVAR; 822 dXSARGS; 823 if (items != 1) 824 croak_xs_usage(cv, "sv"); 825 sv_utf8_encode(ST(0)); 826 XSRETURN_EMPTY; 827 } 828 829 XS(XS_utf8_decode) 830 { 831 dVAR; 832 dXSARGS; 833 if (items != 1) 834 croak_xs_usage(cv, "sv"); 835 else { 836 SV * const sv = ST(0); 837 const bool RETVAL = sv_utf8_decode(sv); 838 ST(0) = boolSV(RETVAL); 839 sv_2mortal(ST(0)); 840 } 841 XSRETURN(1); 842 } 843 844 XS(XS_utf8_upgrade) 845 { 846 dVAR; 847 dXSARGS; 848 if (items != 1) 849 croak_xs_usage(cv, "sv"); 850 else { 851 SV * const sv = ST(0); 852 STRLEN RETVAL; 853 dXSTARG; 854 855 RETVAL = sv_utf8_upgrade(sv); 856 XSprePUSH; PUSHi((IV)RETVAL); 857 } 858 XSRETURN(1); 859 } 860 861 XS(XS_utf8_downgrade) 862 { 863 dVAR; 864 dXSARGS; 865 if (items < 1 || items > 2) 866 croak_xs_usage(cv, "sv, failok=0"); 867 else { 868 SV * const sv = ST(0); 869 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1)); 870 const bool RETVAL = sv_utf8_downgrade(sv, failok); 871 872 ST(0) = boolSV(RETVAL); 873 sv_2mortal(ST(0)); 874 } 875 XSRETURN(1); 876 } 877 878 XS(XS_utf8_native_to_unicode) 879 { 880 dVAR; 881 dXSARGS; 882 const UV uv = SvUV(ST(0)); 883 884 if (items > 1) 885 croak_xs_usage(cv, "sv"); 886 887 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv))); 888 XSRETURN(1); 889 } 890 891 XS(XS_utf8_unicode_to_native) 892 { 893 dVAR; 894 dXSARGS; 895 const UV uv = SvUV(ST(0)); 896 897 if (items > 1) 898 croak_xs_usage(cv, "sv"); 899 900 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv))); 901 XSRETURN(1); 902 } 903 904 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ 905 { 906 dVAR; 907 dXSARGS; 908 SV * const sv = SvRV(ST(0)); 909 PERL_UNUSED_ARG(cv); 910 911 if (items == 1) { 912 if (SvREADONLY(sv)) 913 XSRETURN_YES; 914 else 915 XSRETURN_NO; 916 } 917 else if (items == 2) { 918 if (SvTRUE(ST(1))) { 919 SvREADONLY_on(sv); 920 XSRETURN_YES; 921 } 922 else { 923 /* I hope you really know what you are doing. */ 924 SvREADONLY_off(sv); 925 XSRETURN_NO; 926 } 927 } 928 XSRETURN_UNDEF; /* Can't happen. */ 929 } 930 931 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ 932 { 933 dVAR; 934 dXSARGS; 935 SV * const sv = SvRV(ST(0)); 936 PERL_UNUSED_ARG(cv); 937 938 if (items == 1) 939 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */ 940 else if (items == 2) { 941 /* I hope you really know what you are doing. */ 942 SvREFCNT(sv) = SvIV(ST(1)); 943 XSRETURN_IV(SvREFCNT(sv)); 944 } 945 XSRETURN_UNDEF; /* Can't happen. */ 946 } 947 948 XS(XS_Internals_hv_clear_placehold) 949 { 950 dVAR; 951 dXSARGS; 952 953 if (items != 1) 954 croak_xs_usage(cv, "hv"); 955 else { 956 HV * const hv = MUTABLE_HV(SvRV(ST(0))); 957 hv_clear_placeholders(hv); 958 XSRETURN(0); 959 } 960 } 961 962 XS(XS_Regexp_DESTROY) 963 { 964 PERL_UNUSED_CONTEXT; 965 PERL_UNUSED_ARG(cv); 966 } 967 968 XS(XS_PerlIO_get_layers) 969 { 970 dVAR; 971 dXSARGS; 972 if (items < 1 || items % 2 == 0) 973 croak_xs_usage(cv, "filehandle[,args]"); 974 #ifdef USE_PERLIO 975 { 976 SV * sv; 977 GV * gv; 978 IO * io; 979 bool input = TRUE; 980 bool details = FALSE; 981 982 if (items > 1) { 983 SV * const *svp; 984 for (svp = MARK + 2; svp <= SP; svp += 2) { 985 SV * const * const varp = svp; 986 SV * const * const valp = svp + 1; 987 STRLEN klen; 988 const char * const key = SvPV_const(*varp, klen); 989 990 switch (*key) { 991 case 'i': 992 if (klen == 5 && memEQ(key, "input", 5)) { 993 input = SvTRUE(*valp); 994 break; 995 } 996 goto fail; 997 case 'o': 998 if (klen == 6 && memEQ(key, "output", 6)) { 999 input = !SvTRUE(*valp); 1000 break; 1001 } 1002 goto fail; 1003 case 'd': 1004 if (klen == 7 && memEQ(key, "details", 7)) { 1005 details = SvTRUE(*valp); 1006 break; 1007 } 1008 goto fail; 1009 default: 1010 fail: 1011 Perl_croak(aTHX_ 1012 "get_layers: unknown argument '%s'", 1013 key); 1014 } 1015 } 1016 1017 SP -= (items - 1); 1018 } 1019 1020 sv = POPs; 1021 gv = MUTABLE_GV(sv); 1022 1023 if (!isGV(sv)) { 1024 if (SvROK(sv) && isGV(SvRV(sv))) 1025 gv = MUTABLE_GV(SvRV(sv)); 1026 else if (SvPOKp(sv)) 1027 gv = gv_fetchsv(sv, 0, SVt_PVIO); 1028 } 1029 1030 if (gv && (io = GvIO(gv))) { 1031 AV* const av = PerlIO_get_layers(aTHX_ input ? 1032 IoIFP(io) : IoOFP(io)); 1033 I32 i; 1034 const I32 last = av_len(av); 1035 I32 nitem = 0; 1036 1037 for (i = last; i >= 0; i -= 3) { 1038 SV * const * const namsvp = av_fetch(av, i - 2, FALSE); 1039 SV * const * const argsvp = av_fetch(av, i - 1, FALSE); 1040 SV * const * const flgsvp = av_fetch(av, i, FALSE); 1041 1042 const bool namok = namsvp && *namsvp && SvPOK(*namsvp); 1043 const bool argok = argsvp && *argsvp && SvPOK(*argsvp); 1044 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp); 1045 1046 if (details) { 1047 XPUSHs(namok 1048 ? sv_2mortal(newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp))) 1049 : &PL_sv_undef); 1050 XPUSHs(argok 1051 ? sv_2mortal(newSVpvn(SvPVX_const(*argsvp), SvCUR(*argsvp))) 1052 : &PL_sv_undef); 1053 if (flgok) 1054 mXPUSHi(SvIVX(*flgsvp)); 1055 else 1056 XPUSHs(&PL_sv_undef); 1057 nitem += 3; 1058 } 1059 else { 1060 if (namok && argok) 1061 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")", 1062 SVfARG(*namsvp), 1063 SVfARG(*argsvp)))); 1064 else if (namok) 1065 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf, 1066 SVfARG(*namsvp)))); 1067 else 1068 XPUSHs(&PL_sv_undef); 1069 nitem++; 1070 if (flgok) { 1071 const IV flags = SvIVX(*flgsvp); 1072 1073 if (flags & PERLIO_F_UTF8) { 1074 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP)); 1075 nitem++; 1076 } 1077 } 1078 } 1079 } 1080 1081 SvREFCNT_dec(av); 1082 1083 XSRETURN(nitem); 1084 } 1085 } 1086 #endif 1087 1088 XSRETURN(0); 1089 } 1090 1091 XS(XS_Internals_hash_seed) 1092 { 1093 dVAR; 1094 /* Using dXSARGS would also have dITEM and dSP, 1095 * which define 2 unused local variables. */ 1096 dAXMARK; 1097 PERL_UNUSED_ARG(cv); 1098 PERL_UNUSED_VAR(mark); 1099 XSRETURN_UV(PERL_HASH_SEED); 1100 } 1101 1102 XS(XS_Internals_rehash_seed) 1103 { 1104 dVAR; 1105 /* Using dXSARGS would also have dITEM and dSP, 1106 * which define 2 unused local variables. */ 1107 dAXMARK; 1108 PERL_UNUSED_ARG(cv); 1109 PERL_UNUSED_VAR(mark); 1110 XSRETURN_UV(PL_rehash_seed); 1111 } 1112 1113 XS(XS_Internals_HvREHASH) /* Subject to change */ 1114 { 1115 dVAR; 1116 dXSARGS; 1117 PERL_UNUSED_ARG(cv); 1118 if (SvROK(ST(0))) { 1119 const HV * const hv = (const HV *) SvRV(ST(0)); 1120 if (items == 1 && SvTYPE(hv) == SVt_PVHV) { 1121 if (HvREHASH(hv)) 1122 XSRETURN_YES; 1123 else 1124 XSRETURN_NO; 1125 } 1126 } 1127 Perl_croak(aTHX_ "Internals::HvREHASH $hashref"); 1128 } 1129 1130 XS(XS_re_is_regexp) 1131 { 1132 dVAR; 1133 dXSARGS; 1134 PERL_UNUSED_VAR(cv); 1135 1136 if (items != 1) 1137 croak_xs_usage(cv, "sv"); 1138 1139 SP -= items; 1140 1141 if (SvRXOK(ST(0))) { 1142 XSRETURN_YES; 1143 } else { 1144 XSRETURN_NO; 1145 } 1146 } 1147 1148 XS(XS_re_regnames_count) 1149 { 1150 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 1151 SV * ret; 1152 dVAR; 1153 dXSARGS; 1154 1155 if (items != 0) 1156 croak_xs_usage(cv, ""); 1157 1158 SP -= items; 1159 1160 if (!rx) 1161 XSRETURN_UNDEF; 1162 1163 ret = CALLREG_NAMED_BUFF_COUNT(rx); 1164 1165 SPAGAIN; 1166 1167 if (ret) { 1168 mXPUSHs(ret); 1169 PUTBACK; 1170 return; 1171 } else { 1172 XSRETURN_UNDEF; 1173 } 1174 } 1175 1176 XS(XS_re_regname) 1177 { 1178 dVAR; 1179 dXSARGS; 1180 REGEXP * rx; 1181 U32 flags; 1182 SV * ret; 1183 1184 if (items < 1 || items > 2) 1185 croak_xs_usage(cv, "name[, all ]"); 1186 1187 SP -= items; 1188 1189 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 1190 1191 if (!rx) 1192 XSRETURN_UNDEF; 1193 1194 if (items == 2 && SvTRUE(ST(1))) { 1195 flags = RXapif_ALL; 1196 } else { 1197 flags = RXapif_ONE; 1198 } 1199 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME)); 1200 1201 if (ret) { 1202 mXPUSHs(ret); 1203 XSRETURN(1); 1204 } 1205 XSRETURN_UNDEF; 1206 } 1207 1208 1209 XS(XS_re_regnames) 1210 { 1211 dVAR; 1212 dXSARGS; 1213 REGEXP * rx; 1214 U32 flags; 1215 SV *ret; 1216 AV *av; 1217 I32 length; 1218 I32 i; 1219 SV **entry; 1220 1221 if (items > 1) 1222 croak_xs_usage(cv, "[all]"); 1223 1224 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 1225 1226 if (!rx) 1227 XSRETURN_UNDEF; 1228 1229 if (items == 1 && SvTRUE(ST(0))) { 1230 flags = RXapif_ALL; 1231 } else { 1232 flags = RXapif_ONE; 1233 } 1234 1235 SP -= items; 1236 1237 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES)); 1238 1239 SPAGAIN; 1240 1241 SP -= items; 1242 1243 if (!ret) 1244 XSRETURN_UNDEF; 1245 1246 av = MUTABLE_AV(SvRV(ret)); 1247 length = av_len(av); 1248 1249 for (i = 0; i <= length; i++) { 1250 entry = av_fetch(av, i, FALSE); 1251 1252 if (!entry) 1253 Perl_croak(aTHX_ "NULL array element in re::regnames()"); 1254 1255 mXPUSHs(SvREFCNT_inc_simple_NN(*entry)); 1256 } 1257 1258 SvREFCNT_dec(ret); 1259 1260 PUTBACK; 1261 return; 1262 } 1263 1264 XS(XS_re_regexp_pattern) 1265 { 1266 dVAR; 1267 dXSARGS; 1268 REGEXP *re; 1269 1270 if (items != 1) 1271 croak_xs_usage(cv, "sv"); 1272 1273 SP -= items; 1274 1275 /* 1276 Checks if a reference is a regex or not. If the parameter is 1277 not a ref, or is not the result of a qr// then returns false 1278 in scalar context and an empty list in list context. 1279 Otherwise in list context it returns the pattern and the 1280 modifiers, in scalar context it returns the pattern just as it 1281 would if the qr// was stringified normally, regardless as 1282 to the class of the variable and any strigification overloads 1283 on the object. 1284 */ 1285 1286 if ((re = SvRX(ST(0)))) /* assign deliberate */ 1287 { 1288 /* Housten, we have a regex! */ 1289 SV *pattern; 1290 STRLEN left = 0; 1291 char reflags[6]; 1292 1293 if ( GIMME_V == G_ARRAY ) { 1294 /* 1295 we are in list context so stringify 1296 the modifiers that apply. We ignore "negative 1297 modifiers" in this scenario. 1298 */ 1299 1300 const char *fptr = INT_PAT_MODS; 1301 char ch; 1302 U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME) 1303 >> RXf_PMf_STD_PMMOD_SHIFT); 1304 1305 while((ch = *fptr++)) { 1306 if(match_flags & 1) { 1307 reflags[left++] = ch; 1308 } 1309 match_flags >>= 1; 1310 } 1311 1312 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re), 1313 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP); 1314 1315 /* return the pattern and the modifiers */ 1316 XPUSHs(pattern); 1317 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP)); 1318 XSRETURN(2); 1319 } else { 1320 /* Scalar, so use the string that Perl would return */ 1321 /* return the pattern in (?msix:..) format */ 1322 #if PERL_VERSION >= 11 1323 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re))); 1324 #else 1325 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re), 1326 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP); 1327 #endif 1328 XPUSHs(pattern); 1329 XSRETURN(1); 1330 } 1331 } else { 1332 /* It ain't a regexp folks */ 1333 if ( GIMME_V == G_ARRAY ) { 1334 /* return the empty list */ 1335 XSRETURN_UNDEF; 1336 } else { 1337 /* Because of the (?:..) wrapping involved in a 1338 stringified pattern it is impossible to get a 1339 result for a real regexp that would evaluate to 1340 false. Therefore we can return PL_sv_no to signify 1341 that the object is not a regex, this means that one 1342 can say 1343 1344 if (regex($might_be_a_regex) eq '(?:foo)') { } 1345 1346 and not worry about undefined values. 1347 */ 1348 XSRETURN_NO; 1349 } 1350 } 1351 /* NOT-REACHED */ 1352 } 1353 1354 XS(XS_Tie_Hash_NamedCapture_FETCH) 1355 { 1356 dVAR; 1357 dXSARGS; 1358 REGEXP * rx; 1359 U32 flags; 1360 SV * ret; 1361 1362 if (items != 2) 1363 croak_xs_usage(cv, "$key, $flags"); 1364 1365 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 1366 1367 if (!rx) 1368 XSRETURN_UNDEF; 1369 1370 SP -= items; 1371 1372 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); 1373 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags); 1374 1375 SPAGAIN; 1376 1377 if (ret) { 1378 mXPUSHs(ret); 1379 PUTBACK; 1380 return; 1381 } 1382 XSRETURN_UNDEF; 1383 } 1384 1385 XS(XS_Tie_Hash_NamedCapture_STORE) 1386 { 1387 dVAR; 1388 dXSARGS; 1389 REGEXP * rx; 1390 U32 flags; 1391 1392 if (items != 3) 1393 croak_xs_usage(cv, "$key, $value, $flags"); 1394 1395 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 1396 1397 if (!rx) { 1398 if (!PL_localizing) 1399 Perl_croak(aTHX_ "%s", PL_no_modify); 1400 else 1401 XSRETURN_UNDEF; 1402 } 1403 1404 SP -= items; 1405 1406 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); 1407 CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags); 1408 } 1409 1410 XS(XS_Tie_Hash_NamedCapture_DELETE) 1411 { 1412 dVAR; 1413 dXSARGS; 1414 REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 1415 U32 flags; 1416 1417 if (items != 2) 1418 croak_xs_usage(cv, "$key, $flags"); 1419 1420 if (!rx) 1421 Perl_croak(aTHX_ "%s", PL_no_modify); 1422 1423 SP -= items; 1424 1425 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); 1426 CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags); 1427 } 1428 1429 XS(XS_Tie_Hash_NamedCapture_CLEAR) 1430 { 1431 dVAR; 1432 dXSARGS; 1433 REGEXP * rx; 1434 U32 flags; 1435 1436 if (items != 1) 1437 croak_xs_usage(cv, "$flags"); 1438 1439 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 1440 1441 if (!rx) 1442 Perl_croak(aTHX_ "%s", PL_no_modify); 1443 1444 SP -= items; 1445 1446 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); 1447 CALLREG_NAMED_BUFF_CLEAR(rx, flags); 1448 } 1449 1450 XS(XS_Tie_Hash_NamedCapture_EXISTS) 1451 { 1452 dVAR; 1453 dXSARGS; 1454 REGEXP * rx; 1455 U32 flags; 1456 SV * ret; 1457 1458 if (items != 2) 1459 croak_xs_usage(cv, "$key, $flags"); 1460 1461 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 1462 1463 if (!rx) 1464 XSRETURN_UNDEF; 1465 1466 SP -= items; 1467 1468 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); 1469 ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags); 1470 1471 SPAGAIN; 1472 1473 XPUSHs(ret); 1474 PUTBACK; 1475 return; 1476 } 1477 1478 XS(XS_Tie_Hash_NamedCapture_FIRSTK) 1479 { 1480 dVAR; 1481 dXSARGS; 1482 REGEXP * rx; 1483 U32 flags; 1484 SV * ret; 1485 1486 if (items != 1) 1487 croak_xs_usage(cv, ""); 1488 1489 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 1490 1491 if (!rx) 1492 XSRETURN_UNDEF; 1493 1494 SP -= items; 1495 1496 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); 1497 ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags); 1498 1499 SPAGAIN; 1500 1501 if (ret) { 1502 mXPUSHs(ret); 1503 PUTBACK; 1504 } else { 1505 XSRETURN_UNDEF; 1506 } 1507 1508 } 1509 1510 XS(XS_Tie_Hash_NamedCapture_NEXTK) 1511 { 1512 dVAR; 1513 dXSARGS; 1514 REGEXP * rx; 1515 U32 flags; 1516 SV * ret; 1517 1518 if (items != 2) 1519 croak_xs_usage(cv, "$lastkey"); 1520 1521 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 1522 1523 if (!rx) 1524 XSRETURN_UNDEF; 1525 1526 SP -= items; 1527 1528 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); 1529 ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags); 1530 1531 SPAGAIN; 1532 1533 if (ret) { 1534 mXPUSHs(ret); 1535 } else { 1536 XSRETURN_UNDEF; 1537 } 1538 PUTBACK; 1539 } 1540 1541 XS(XS_Tie_Hash_NamedCapture_SCALAR) 1542 { 1543 dVAR; 1544 dXSARGS; 1545 REGEXP * rx; 1546 U32 flags; 1547 SV * ret; 1548 1549 if (items != 1) 1550 croak_xs_usage(cv, ""); 1551 1552 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 1553 1554 if (!rx) 1555 XSRETURN_UNDEF; 1556 1557 SP -= items; 1558 1559 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); 1560 ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags); 1561 1562 SPAGAIN; 1563 1564 if (ret) { 1565 mXPUSHs(ret); 1566 PUTBACK; 1567 return; 1568 } else { 1569 XSRETURN_UNDEF; 1570 } 1571 } 1572 1573 XS(XS_Tie_Hash_NamedCapture_flags) 1574 { 1575 dVAR; 1576 dXSARGS; 1577 1578 if (items != 0) 1579 croak_xs_usage(cv, ""); 1580 1581 mXPUSHu(RXapif_ONE); 1582 mXPUSHu(RXapif_ALL); 1583 PUTBACK; 1584 return; 1585 } 1586 1587 1588 /* 1589 * Local variables: 1590 * c-indentation-style: bsd 1591 * c-basic-offset: 4 1592 * indent-tabs-mode: t 1593 * End: 1594 * 1595 * ex: set ts=8 sts=4 sw=4 noet: 1596 */ 1597