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