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