/* universal.c * * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, * 2005, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * "The roots of those mountains must be roots indeed; there must be * great secrets buried there which have not been discovered since the * beginning." --Gandalf, relating Gollum's story */ /* This file contains the code that implements the functions in Perl's * UNIVERSAL package, such as UNIVERSAL->can(). */ #include "EXTERN.h" #define PERL_IN_UNIVERSAL_C #include "perl.h" #ifdef USE_PERLIO #include "perliol.h" /* For the PERLIO_F_XXX */ #endif /* * Contributed by Graham Barr * The main guts of traverse_isa was actually copied from gv_fetchmeth */ STATIC SV * S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, int len, int level) 28867 { 28867 AV* av; 28867 GV* gv; 28867 GV** gvp; 28867 HV* hv = Nullhv; 28867 SV* subgen = Nullsv; 28867 const char *hvname; /* A stash/class can go by many names (ie. User == main::User), so we compare the stash itself just in case */ 28867 if (name_stash && (stash == name_stash)) 23661 return &PL_sv_yes; 5206 hvname = HvNAME_get(stash); 5206 if (strEQ(hvname, name)) ###### return &PL_sv_yes; 5206 if (strEQ(name, "UNIVERSAL")) 6 return &PL_sv_yes; 5200 if (level > 100) ###### Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", hvname); 5200 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE); 5200 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv)) && (hv = GvHV(gv))) { 4414 if (SvIV(subgen) == (IV)PL_sub_generation) { 3819 SV* sv; 3819 SV** svp = (SV**)hv_fetch(hv, name, len, FALSE); 3819 if (svp && (sv = *svp) != (SV*)&PL_sv_undef) { DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n", 3068 name, hvname) ); 3068 return sv; } } else { DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n", 595 hvname) ); 595 hv_clear(hv); 595 sv_setiv(subgen, PL_sub_generation); } } 2132 gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); 2132 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { 1662 if (!hv || !subgen) { 316 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE); 316 gv = *gvp; 316 if (SvTYPE(gv) != SVt_PVGV) 316 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE); 316 if (!hv) 316 hv = GvHVn(gv); 316 if (!subgen) { 316 subgen = newSViv(PL_sub_generation); 316 GvSV(gv) = subgen; } } 1662 if (hv) { 1662 SV** svp = AvARRAY(av); /* NOTE: No support for tied ISA */ 1662 I32 items = AvFILLp(av) + 1; 3640 while (items--) { 2055 SV* sv = *svp++; 2055 HV* basestash = gv_stashsv(sv, FALSE); 2055 if (!basestash) { ###### if (ckWARN(WARN_MISC)) ###### Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA", sv, hvname); ###### continue; } 2055 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash, len, level + 1)) { 77 (void)hv_store(hv,name,len,&PL_sv_yes,0); 77 return &PL_sv_yes; } } 1585 (void)hv_store(hv,name,len,&PL_sv_no,0); } } 2055 return &PL_sv_no; } /* =head1 SV Manipulation Functions =for apidoc sv_derived_from Returns a boolean indicating whether the SV is derived from the specified class. This is the function that implements C. It works for class names as well as for objects. =cut */ bool Perl_sv_derived_from(pTHX_ SV *sv, const char *name) 66286 { 66286 const char *type = Nullch; 66286 HV *stash = Nullhv; 66286 HV *name_stash; 66286 if (SvGMAGICAL(sv)) 10 mg_get(sv) ; 66286 if (SvROK(sv)) { 31543 sv = SvRV(sv); 31543 type = sv_reftype(sv,0); 31543 if (SvOBJECT(sv)) 26523 stash = SvSTASH(sv); } else { 34743 stash = gv_stashsv(sv, FALSE); } 66286 name_stash = gv_stashpv(name, FALSE); 66286 return (type && strEQ(type,name)) || (stash && isa_lookup(stash, name, name_stash, strlen(name), 0) == &PL_sv_yes) ? TRUE : FALSE ; } #include "XSUB.h" PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv); PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv); PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv); XS(XS_version_new); XS(XS_version_stringify); XS(XS_version_numify); XS(XS_version_normal); XS(XS_version_vcmp); XS(XS_version_boolean); #ifdef HASATTRIBUTE_NORETURN XS(XS_version_noop) __attribute__noreturn__; #else XS(XS_version_noop); #endif XS(XS_version_is_alpha); XS(XS_version_qv); XS(XS_utf8_is_utf8); XS(XS_utf8_valid); XS(XS_utf8_encode); XS(XS_utf8_decode); XS(XS_utf8_upgrade); XS(XS_utf8_downgrade); XS(XS_utf8_unicode_to_native); XS(XS_utf8_native_to_unicode); XS(XS_Internals_SvREADONLY); XS(XS_Internals_SvREFCNT); XS(XS_Internals_hv_clear_placehold); XS(XS_PerlIO_get_layers); XS(XS_Regexp_DESTROY); XS(XS_Internals_hash_seed); XS(XS_Internals_rehash_seed); XS(XS_Internals_HvREHASH); void Perl_boot_core_UNIVERSAL(pTHX) 4500 { 4500 const char file[] = __FILE__; 4500 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); 4500 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); 4500 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file); { /* register the overloading (type 'A') magic */ 4500 PL_amagic_generation++; /* Make it findable via fetchmethod */ 4500 newXS("version::()", XS_version_noop, file); 4500 newXS("version::new", XS_version_new, file); 4500 newXS("version::(\"\"", XS_version_stringify, file); 4500 newXS("version::stringify", XS_version_stringify, file); 4500 newXS("version::(0+", XS_version_numify, file); 4500 newXS("version::numify", XS_version_numify, file); 4500 newXS("version::normal", XS_version_normal, file); 4500 newXS("version::(cmp", XS_version_vcmp, file); 4500 newXS("version::(<=>", XS_version_vcmp, file); 4500 newXS("version::vcmp", XS_version_vcmp, file); 4500 newXS("version::(bool", XS_version_boolean, file); 4500 newXS("version::boolean", XS_version_boolean, file); 4500 newXS("version::(nomethod", XS_version_noop, file); 4500 newXS("version::noop", XS_version_noop, file); 4500 newXS("version::is_alpha", XS_version_is_alpha, file); 4500 newXS("version::qv", XS_version_qv, file); } 4500 newXS("utf8::is_utf8", XS_utf8_is_utf8, file); 4500 newXS("utf8::valid", XS_utf8_valid, file); 4500 newXS("utf8::encode", XS_utf8_encode, file); 4500 newXS("utf8::decode", XS_utf8_decode, file); 4500 newXS("utf8::upgrade", XS_utf8_upgrade, file); 4500 newXS("utf8::downgrade", XS_utf8_downgrade, file); 4500 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file); 4500 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file); 4500 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$"); 4500 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$"); newXSproto("Internals::hv_clear_placeholders", 4500 XS_Internals_hv_clear_placehold, file, "\\%"); newXSproto("PerlIO::get_layers", 4500 XS_PerlIO_get_layers, file, "*;@"); 4500 newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file); 4500 newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, ""); 4500 newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, ""); 4500 newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%"); } XS(XS_UNIVERSAL_isa) 25166 { 25166 dXSARGS; 25166 SV *sv; 25166 const char *name; 25166 if (items != 2) ###### Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)"); 25166 sv = ST(0); 25166 if (SvGMAGICAL(sv)) 10 mg_get(sv); 25166 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) 953 XSRETURN_UNDEF; 24213 name = SvPV_nolen_const(ST(1)); 24213 ST(0) = boolSV(sv_derived_from(sv, name)); 24213 XSRETURN(1); } XS(XS_UNIVERSAL_can) 88611 { 88611 dXSARGS; 88611 SV *sv; 88611 const char *name; 88611 SV *rv; 88611 HV *pkg = NULL; 88611 if (items != 2) ###### Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)"); 88611 sv = ST(0); 88611 if (SvGMAGICAL(sv)) 2 mg_get(sv); 88611 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) 9 XSRETURN_UNDEF; 88602 name = SvPV_nolen_const(ST(1)); 88602 rv = &PL_sv_undef; 88602 if (SvROK(sv)) { 80103 sv = (SV*)SvRV(sv); 80103 if (SvOBJECT(sv)) 80054 pkg = SvSTASH(sv); } else { 8499 pkg = gv_stashsv(sv, FALSE); } 88602 if (pkg) { 88545 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE); 88545 if (gv && isGV(gv)) 39502 rv = sv_2mortal(newRV((SV*)GvCV(gv))); } 88602 ST(0) = rv; 88602 XSRETURN(1); } XS(XS_UNIVERSAL_VERSION) 277 { 277 dXSARGS; 277 HV *pkg; 277 GV **gvp; 277 GV *gv; 277 SV *sv; 277 const char *undef; 277 if (SvROK(ST(0))) { 3 sv = (SV*)SvRV(ST(0)); 3 if (!SvOBJECT(sv)) ###### Perl_croak(aTHX_ "Cannot find version of an unblessed reference"); 3 pkg = SvSTASH(sv); } else { 274 pkg = gv_stashsv(ST(0), FALSE); } 277 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**); 277 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) { 276 SV *nsv = sv_newmortal(); 276 sv_setsv(nsv, sv); 276 sv = nsv; 276 if ( !sv_derived_from(sv, "version")) 276 upg_version(sv); 276 undef = Nullch; } else { 1 sv = (SV*)&PL_sv_undef; 1 undef = "(undef)"; } 277 if (items > 1) { 243 SV *req = ST(1); 243 if (undef) { 1 if (pkg) { ###### const char *name = HvNAME_get(pkg); ###### Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed", name, name); } else { 1 Perl_croak(aTHX_ "%s defines neither package nor VERSION--version check failed", 1 SvPVx_nolen_const(ST(0)) ); } } 242 if ( !sv_derived_from(req, "version")) { /* req may very well be R/O, so create a new object */ 242 SV *nsv = sv_newmortal(); 242 sv_setsv(nsv, req); 242 req = nsv; 242 upg_version(req); } 242 if ( vcmp( req, sv ) > 0 ) 15 Perl_croak(aTHX_ "%s version %"SVf" (%"SVf") required--" "this is only version %"SVf" (%"SVf")", HvNAME_get(pkg), vnumify(req),vnormal(req),vnumify(sv),vnormal(sv)); } 261 if ( SvOK(sv) && sv_derived_from(sv, "version") ) { 261 ST(0) = vnumify(sv); } else { ###### ST(0) = sv; } 261 XSRETURN(1); } XS(XS_version_new) 82 { 82 dXSARGS; 82 if (items > 3) ###### Perl_croak(aTHX_ "Usage: version::new(class, version)"); 82 SP -= items; { 82 SV *vs = ST(1); 82 SV *rv; 82 const char *classname; /* get the class if called as an object method */ 82 if ( sv_isobject(ST(0)) ) { 4 classname = HvNAME(SvSTASH(SvRV(ST(0)))); } else { 78 classname = (char *)SvPV_nolen(ST(0)); } 82 if ( items == 1 ) { /* no parameter provided */ 2 if ( sv_isobject(ST(0)) ) { /* copy existing object */ 2 vs = ST(0); } else { /* create empty object */ ###### vs = sv_newmortal(); ###### sv_setpvn(vs,"",0); } } 80 else if ( items == 3 ) { 4 vs = sv_newmortal(); 4 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2))); } 82 rv = new_version(vs); 78 if ( strcmp(classname,"version") != 0 ) /* inherited new() */ 34 sv_bless(rv, gv_stashpv(classname,TRUE)); 78 PUSHs(sv_2mortal(rv)); 78 PUTBACK; return; } } XS(XS_version_stringify) 48 { 48 dXSARGS; 48 if (items < 1) ###### Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)"); 48 SP -= items; { 48 SV * lobj = Nullsv; 48 if (sv_derived_from(ST(0), "version")) { 48 lobj = SvRV(ST(0)); } else ###### Perl_croak(aTHX_ "lobj is not of type version"); 48 PUSHs(sv_2mortal(vstringify(lobj))); 48 PUTBACK; return; } } XS(XS_version_numify) 13 { 13 dXSARGS; 13 if (items < 1) ###### Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)"); 13 SP -= items; { 13 SV * lobj = Nullsv; 13 if (sv_derived_from(ST(0), "version")) { 13 lobj = SvRV(ST(0)); } else ###### Perl_croak(aTHX_ "lobj is not of type version"); 13 PUSHs(sv_2mortal(vnumify(lobj))); 13 PUTBACK; return; } } XS(XS_version_normal) 3 { 3 dXSARGS; 3 if (items < 1) ###### Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)"); 3 SP -= items; { 3 SV * lobj = Nullsv; 3 if (sv_derived_from(ST(0), "version")) { 3 lobj = SvRV(ST(0)); } else ###### Perl_croak(aTHX_ "lobj is not of type version"); 3 PUSHs(sv_2mortal(vnormal(lobj))); 3 PUTBACK; return; } } XS(XS_version_vcmp) 1579 { 1579 dXSARGS; 1579 if (items < 1) ###### Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)"); 1579 SP -= items; { 1579 SV * lobj = Nullsv; 1579 if (sv_derived_from(ST(0), "version")) { 1579 lobj = SvRV(ST(0)); } else ###### Perl_croak(aTHX_ "lobj is not of type version"); { 1579 SV *rs; 1579 SV *rvs; 1579 SV * robj = ST(1); 1579 IV swap = (IV)SvIV(ST(2)); 1579 if ( ! sv_derived_from(robj, "version") ) { 1518 robj = new_version(robj); } 1579 rvs = SvRV(robj); 1579 if ( swap ) { 10 rs = newSViv(vcmp(rvs,lobj)); } else { 1569 rs = newSViv(vcmp(lobj,rvs)); } 1579 PUSHs(sv_2mortal(rs)); } 1579 PUTBACK; return; } } XS(XS_version_boolean) 1476 { 1476 dXSARGS; 1476 if (items < 1) ###### Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)"); 1476 SP -= items; { 1476 SV * lobj = Nullsv; 1476 if (sv_derived_from(ST(0), "version")) { 1476 lobj = SvRV(ST(0)); } else ###### Perl_croak(aTHX_ "lobj is not of type version"); { 1476 SV *rs; 1476 rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) ); 1476 PUSHs(sv_2mortal(rs)); } 1476 PUTBACK; return; } } XS(XS_version_noop) 10 { 10 dXSARGS; 10 if (items < 1) ###### Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)"); 10 if (sv_derived_from(ST(0), "version")) 10 Perl_croak(aTHX_ "operation not supported with version object"); else ###### Perl_croak(aTHX_ "lobj is not of type version"); #ifndef HASATTRIBUTE_NORETURN XSRETURN_EMPTY; #endif } XS(XS_version_is_alpha) 4 { 4 dXSARGS; 4 if (items != 1) ###### Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)"); 4 SP -= items; { 4 SV * lobj = Nullsv; 4 if (sv_derived_from(ST(0), "version")) 4 lobj = ST(0); else ###### Perl_croak(aTHX_ "lobj is not of type version"); { 4 if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) ) 2 XSRETURN_YES; else 2 XSRETURN_NO; } 4 PUTBACK; 4 return; } } XS(XS_version_qv) 6 { 6 dXSARGS; 6 if (items != 1) ###### Perl_croak(aTHX_ "Usage: version::qv(ver)"); 6 SP -= items; { 6 SV * ver = ST(0); 6 if ( !SvVOK(ver) ) /* only need to do with if not already v-string */ { 4 SV *vs = sv_newmortal(); 4 char *version; 4 if ( SvNOK(ver) ) /* may get too much accuracy */ { 2 char tbuf[64]; 2 sprintf(tbuf,"%.9"NVgf, SvNVX(ver)); 2 version = savepv(tbuf); } else { 2 version = savesvpv(ver); } 4 (void)scan_version(version,vs,TRUE); 4 Safefree(version); 4 PUSHs(vs); } else { 2 PUSHs(sv_2mortal(new_version(ver))); } 6 PUTBACK; return; } } XS(XS_utf8_is_utf8) 57 { 57 dXSARGS; 57 if (items != 1) ###### Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)"); { 57 const SV *sv = ST(0); { 57 if (SvUTF8(sv)) 28 XSRETURN_YES; else 29 XSRETURN_NO; } } 57 XSRETURN_EMPTY; } XS(XS_utf8_valid) 524 { 524 dXSARGS; 524 if (items != 1) ###### Perl_croak(aTHX_ "Usage: utf8::valid(sv)"); { 524 SV * sv = ST(0); { 524 STRLEN len; 524 const char *s = SvPV_const(sv,len); 524 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len)) 524 XSRETURN_YES; else ###### XSRETURN_NO; } } 524 XSRETURN_EMPTY; } XS(XS_utf8_encode) 268352 { 268352 dXSARGS; 268352 if (items != 1) ###### Perl_croak(aTHX_ "Usage: utf8::encode(sv)"); { 268352 SV * sv = ST(0); 268352 sv_utf8_encode(sv); } 268351 XSRETURN_EMPTY; } XS(XS_utf8_decode) 17 { 17 dXSARGS; 17 if (items != 1) ###### Perl_croak(aTHX_ "Usage: utf8::decode(sv)"); { 17 SV * sv = ST(0); 17 const bool RETVAL = sv_utf8_decode(sv); 17 ST(0) = boolSV(RETVAL); 17 sv_2mortal(ST(0)); } 17 XSRETURN(1); } XS(XS_utf8_upgrade) 86 { 86 dXSARGS; 86 if (items != 1) ###### Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)"); { 86 SV * sv = ST(0); 86 STRLEN RETVAL; 86 dXSTARG; 86 RETVAL = sv_utf8_upgrade(sv); 86 XSprePUSH; PUSHi((IV)RETVAL); } 86 XSRETURN(1); } XS(XS_utf8_downgrade) 40 { 40 dXSARGS; 40 if (items < 1 || items > 2) ###### Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)"); { 40 SV * sv = ST(0); 40 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1)); 40 const bool RETVAL = sv_utf8_downgrade(sv, failok); 39 ST(0) = boolSV(RETVAL); 39 sv_2mortal(ST(0)); } 39 XSRETURN(1); } XS(XS_utf8_native_to_unicode) ###### { ###### dXSARGS; ###### const UV uv = SvUV(ST(0)); ###### if (items > 1) ###### Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)"); ###### ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv))); ###### XSRETURN(1); } XS(XS_utf8_unicode_to_native) 268273 { 268273 dXSARGS; 268273 const UV uv = SvUV(ST(0)); 268273 if (items > 1) ###### Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)"); 268273 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv))); 268273 XSRETURN(1); } XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ 307 { 307 dXSARGS; 307 SV *sv = SvRV(ST(0)); 307 if (items == 1) { 109 if (SvREADONLY(sv)) 92 XSRETURN_YES; else 17 XSRETURN_NO; } 198 else if (items == 2) { 198 if (SvTRUE(ST(1))) { 114 SvREADONLY_on(sv); 114 XSRETURN_YES; } else { /* I hope you really know what you are doing. */ 84 SvREADONLY_off(sv); 84 XSRETURN_NO; } } ###### XSRETURN_UNDEF; /* Can't happen. */ } XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ 8 { 8 dXSARGS; 8 SV *sv = SvRV(ST(0)); 8 if (items == 1) 8 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */ ###### else if (items == 2) { /* I hope you really know what you are doing. */ ###### SvREFCNT(sv) = SvIV(ST(1)); ###### XSRETURN_IV(SvREFCNT(sv)); } ###### XSRETURN_UNDEF; /* Can't happen. */ } XS(XS_Internals_hv_clear_placehold) 34 { 34 dXSARGS; 34 HV *hv = (HV *) SvRV(ST(0)); 34 if (items != 1) ###### Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)"); 34 hv_clear_placeholders(hv); 34 XSRETURN(0); } XS(XS_Regexp_DESTROY) 31483 { 31483 PERL_UNUSED_ARG(cv); } XS(XS_PerlIO_get_layers) 13 { 13 dXSARGS; 13 if (items < 1 || items % 2 == 0) ###### Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])"); #ifdef USE_PERLIO { 13 SV * sv; 13 GV * gv; 13 IO * io; 13 bool input = TRUE; 13 bool details = FALSE; 13 if (items > 1) { 2 SV **svp; 4 for (svp = MARK + 2; svp <= SP; svp += 2) { 2 SV **varp = svp; 2 SV **valp = svp + 1; 2 STRLEN klen; 2 const char *key = SvPV_const(*varp, klen); 2 switch (*key) { case 'i': 1 if (klen == 5 && memEQ(key, "input", 5)) { 1 input = SvTRUE(*valp); 1 break; } 1 goto fail; case 'o': 1 if (klen == 6 && memEQ(key, "output", 6)) { 1 input = !SvTRUE(*valp); 1 break; } ###### goto fail; case 'd': ###### if (klen == 7 && memEQ(key, "details", 7)) { ###### details = SvTRUE(*valp); ###### break; } ###### goto fail; default: fail: ###### Perl_croak(aTHX_ "get_layers: unknown argument '%s'", key); } } 2 SP -= (items - 1); } 13 sv = POPs; 13 gv = (GV*)sv; 13 if (!isGV(sv)) { 12 if (SvROK(sv) && isGV(SvRV(sv))) ###### gv = (GV*)SvRV(sv); else 12 gv = gv_fetchsv(sv, FALSE, SVt_PVIO); } 13 if (gv && (io = GvIO(gv))) { 13 dTARGET; 13 AV* av = PerlIO_get_layers(aTHX_ input ? 13 IoIFP(io) : IoOFP(io)); 13 I32 i; 13 I32 last = av_len(av); 13 I32 nitem = 0; 47 for (i = last; i >= 0; i -= 3) { 34 SV **namsvp; 34 SV **argsvp; 34 SV **flgsvp; 34 bool namok, argok, flgok; 34 namsvp = av_fetch(av, i - 2, FALSE); 34 argsvp = av_fetch(av, i - 1, FALSE); 34 flgsvp = av_fetch(av, i, FALSE); 34 namok = namsvp && *namsvp && SvPOK(*namsvp); 34 argok = argsvp && *argsvp && SvPOK(*argsvp); 34 flgok = flgsvp && *flgsvp && SvIOK(*flgsvp); 34 if (details) { XPUSHs(namok ? newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp)) ###### : &PL_sv_undef); XPUSHs(argok ? newSVpvn(SvPVX_const(*argsvp), SvCUR(*argsvp)) ###### : &PL_sv_undef); ###### if (flgok) ###### XPUSHi(SvIVX(*flgsvp)); else ###### XPUSHs(&PL_sv_undef); ###### nitem += 3; } else { 34 if (namok && argok) XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")", 3 *namsvp, *argsvp)); 31 else if (namok) 31 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp)); else ###### XPUSHs(&PL_sv_undef); 34 nitem++; 34 if (flgok) { 34 IV flags = SvIVX(*flgsvp); 34 if (flags & PERLIO_F_UTF8) { 4 XPUSHs(newSVpvn("utf8", 4)); 4 nitem++; } } } } 13 SvREFCNT_dec(av); 13 XSRETURN(nitem); } } #endif ###### XSRETURN(0); } XS(XS_Internals_hash_seed) ###### { /* Using dXSARGS would also have dITEM and dSP, * which define 2 unused local variables. */ ###### dAXMARK; ###### PERL_UNUSED_ARG(cv); ###### PERL_UNUSED_VAR(mark); ###### XSRETURN_UV(PERL_HASH_SEED); } XS(XS_Internals_rehash_seed) 1 { /* Using dXSARGS would also have dITEM and dSP, * which define 2 unused local variables. */ 1 dAXMARK; 1 PERL_UNUSED_ARG(cv); 1 PERL_UNUSED_VAR(mark); 1 XSRETURN_UV(PL_rehash_seed); } XS(XS_Internals_HvREHASH) /* Subject to change */ 5 { 5 dXSARGS; 5 if (SvROK(ST(0))) { 5 const HV *hv = (HV *) SvRV(ST(0)); 5 if (items == 1 && SvTYPE(hv) == SVt_PVHV) { 5 if (HvREHASH(hv)) 2 XSRETURN_YES; else 3 XSRETURN_NO; } } ###### Perl_croak(aTHX_ "Internals::HvREHASH $hashref"); } /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */