1N/A/* universal.c
1N/A *
1N/A * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
1N/A * by Larry Wall and others
1N/A *
1N/A * You may distribute under the terms of either the GNU General Public
1N/A * License or the Artistic License, as specified in the README file.
1N/A *
1N/A */
1N/A
1N/A/*
1N/A * "The roots of those mountains must be roots indeed; there must be
1N/A * great secrets buried there which have not been discovered since the
1N/A * beginning." --Gandalf, relating Gollum's story
1N/A */
1N/A
1N/A#include "EXTERN.h"
1N/A#define PERL_IN_UNIVERSAL_C
1N/A#include "perl.h"
1N/A
1N/A#ifdef USE_PERLIO
1N/A#include "perliol.h" /* For the PERLIO_F_XXX */
1N/A#endif
1N/A
1N/A/*
1N/A * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
1N/A * The main guts of traverse_isa was actually copied from gv_fetchmeth
1N/A */
1N/A
1N/ASTATIC SV *
1N/AS_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
1N/A int len, int level)
1N/A{
1N/A AV* av;
1N/A GV* gv;
1N/A GV** gvp;
1N/A HV* hv = Nullhv;
1N/A SV* subgen = Nullsv;
1N/A
1N/A /* A stash/class can go by many names (ie. User == main::User), so
1N/A we compare the stash itself just in case */
1N/A if (name_stash && (stash == name_stash))
1N/A return &PL_sv_yes;
1N/A
1N/A if (strEQ(HvNAME(stash), name))
1N/A return &PL_sv_yes;
1N/A
1N/A if (strEQ(name, "UNIVERSAL"))
1N/A return &PL_sv_yes;
1N/A
1N/A if (level > 100)
1N/A Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
1N/A HvNAME(stash));
1N/A
1N/A gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
1N/A
1N/A if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
1N/A && (hv = GvHV(gv)))
1N/A {
1N/A if (SvIV(subgen) == (IV)PL_sub_generation) {
1N/A SV* sv;
1N/A SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
1N/A if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
1N/A DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
1N/A name, HvNAME(stash)) );
1N/A return sv;
1N/A }
1N/A }
1N/A else {
1N/A DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
1N/A HvNAME(stash)) );
1N/A hv_clear(hv);
1N/A sv_setiv(subgen, PL_sub_generation);
1N/A }
1N/A }
1N/A
1N/A gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
1N/A
1N/A if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
1N/A if (!hv || !subgen) {
1N/A gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
1N/A
1N/A gv = *gvp;
1N/A
1N/A if (SvTYPE(gv) != SVt_PVGV)
1N/A gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
1N/A
1N/A if (!hv)
1N/A hv = GvHVn(gv);
1N/A if (!subgen) {
1N/A subgen = newSViv(PL_sub_generation);
1N/A GvSV(gv) = subgen;
1N/A }
1N/A }
1N/A if (hv) {
1N/A SV** svp = AvARRAY(av);
1N/A /* NOTE: No support for tied ISA */
1N/A I32 items = AvFILLp(av) + 1;
1N/A while (items--) {
1N/A SV* sv = *svp++;
1N/A HV* basestash = gv_stashsv(sv, FALSE);
1N/A if (!basestash) {
1N/A if (ckWARN(WARN_MISC))
1N/A Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1N/A "Can't locate package %"SVf" for @%s::ISA",
1N/A sv, HvNAME(stash));
1N/A continue;
1N/A }
1N/A if (&PL_sv_yes == isa_lookup(basestash, name, name_stash,
1N/A len, level + 1)) {
1N/A (void)hv_store(hv,name,len,&PL_sv_yes,0);
1N/A return &PL_sv_yes;
1N/A }
1N/A }
1N/A (void)hv_store(hv,name,len,&PL_sv_no,0);
1N/A }
1N/A }
1N/A return &PL_sv_no;
1N/A}
1N/A
1N/A/*
1N/A=head1 SV Manipulation Functions
1N/A
1N/A=for apidoc sv_derived_from
1N/A
1N/AReturns a boolean indicating whether the SV is derived from the specified
1N/Aclass. This is the function that implements C<UNIVERSAL::isa>. It works
1N/Afor class names as well as for objects.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/Abool
1N/APerl_sv_derived_from(pTHX_ SV *sv, const char *name)
1N/A{
1N/A char *type;
1N/A HV *stash;
1N/A HV *name_stash;
1N/A
1N/A stash = Nullhv;
1N/A type = Nullch;
1N/A
1N/A if (SvGMAGICAL(sv))
1N/A mg_get(sv) ;
1N/A
1N/A if (SvROK(sv)) {
1N/A sv = SvRV(sv);
1N/A type = sv_reftype(sv,0);
1N/A if (SvOBJECT(sv))
1N/A stash = SvSTASH(sv);
1N/A }
1N/A else {
1N/A stash = gv_stashsv(sv, FALSE);
1N/A }
1N/A
1N/A name_stash = gv_stashpv(name, FALSE);
1N/A
1N/A return (type && strEQ(type,name)) ||
1N/A (stash && isa_lookup(stash, name, name_stash, strlen(name), 0)
1N/A == &PL_sv_yes)
1N/A ? TRUE
1N/A : FALSE ;
1N/A}
1N/A
1N/A#include "XSUB.h"
1N/A
1N/Avoid XS_UNIVERSAL_isa(pTHX_ CV *cv);
1N/Avoid XS_UNIVERSAL_can(pTHX_ CV *cv);
1N/Avoid XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
1N/AXS(XS_utf8_is_utf8);
1N/AXS(XS_utf8_valid);
1N/AXS(XS_utf8_encode);
1N/AXS(XS_utf8_decode);
1N/AXS(XS_utf8_upgrade);
1N/AXS(XS_utf8_downgrade);
1N/AXS(XS_utf8_unicode_to_native);
1N/AXS(XS_utf8_native_to_unicode);
1N/AXS(XS_Internals_SvREADONLY);
1N/AXS(XS_Internals_SvREFCNT);
1N/AXS(XS_Internals_hv_clear_placehold);
1N/AXS(XS_PerlIO_get_layers);
1N/AXS(XS_Regexp_DESTROY);
1N/AXS(XS_Internals_hash_seed);
1N/AXS(XS_Internals_rehash_seed);
1N/AXS(XS_Internals_HvREHASH);
1N/A
1N/Avoid
1N/APerl_boot_core_UNIVERSAL(pTHX)
1N/A{
1N/A char *file = __FILE__;
1N/A
1N/A newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
1N/A newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
1N/A newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
1N/A newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
1N/A newXS("utf8::valid", XS_utf8_valid, file);
1N/A newXS("utf8::encode", XS_utf8_encode, file);
1N/A newXS("utf8::decode", XS_utf8_decode, file);
1N/A newXS("utf8::upgrade", XS_utf8_upgrade, file);
1N/A newXS("utf8::downgrade", XS_utf8_downgrade, file);
1N/A newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
1N/A newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
1N/A newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
1N/A newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
1N/A newXSproto("Internals::hv_clear_placeholders",
1N/A XS_Internals_hv_clear_placehold, file, "\\%");
1N/A newXSproto("PerlIO::get_layers",
1N/A XS_PerlIO_get_layers, file, "*;@");
1N/A newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
1N/A newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
1N/A newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
1N/A newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
1N/A}
1N/A
1N/A
1N/AXS(XS_UNIVERSAL_isa)
1N/A{
1N/A dXSARGS;
1N/A SV *sv;
1N/A char *name;
1N/A STRLEN n_a;
1N/A
1N/A if (items != 2)
1N/A Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
1N/A
1N/A sv = ST(0);
1N/A
1N/A if (SvGMAGICAL(sv))
1N/A mg_get(sv);
1N/A
1N/A if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
1N/A || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
1N/A XSRETURN_UNDEF;
1N/A
1N/A name = (char *)SvPV(ST(1),n_a);
1N/A
1N/A ST(0) = boolSV(sv_derived_from(sv, name));
1N/A XSRETURN(1);
1N/A}
1N/A
1N/AXS(XS_UNIVERSAL_can)
1N/A{
1N/A dXSARGS;
1N/A SV *sv;
1N/A char *name;
1N/A SV *rv;
1N/A HV *pkg = NULL;
1N/A STRLEN n_a;
1N/A
1N/A if (items != 2)
1N/A Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
1N/A
1N/A sv = ST(0);
1N/A
1N/A if (SvGMAGICAL(sv))
1N/A mg_get(sv);
1N/A
1N/A if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
1N/A || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
1N/A XSRETURN_UNDEF;
1N/A
1N/A name = (char *)SvPV(ST(1),n_a);
1N/A rv = &PL_sv_undef;
1N/A
1N/A if (SvROK(sv)) {
1N/A sv = (SV*)SvRV(sv);
1N/A if (SvOBJECT(sv))
1N/A pkg = SvSTASH(sv);
1N/A }
1N/A else {
1N/A pkg = gv_stashsv(sv, FALSE);
1N/A }
1N/A
1N/A if (pkg) {
1N/A GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
1N/A if (gv && isGV(gv))
1N/A rv = sv_2mortal(newRV((SV*)GvCV(gv)));
1N/A }
1N/A
1N/A ST(0) = rv;
1N/A XSRETURN(1);
1N/A}
1N/A
1N/AXS(XS_UNIVERSAL_VERSION)
1N/A{
1N/A dXSARGS;
1N/A HV *pkg;
1N/A GV **gvp;
1N/A GV *gv;
1N/A SV *sv;
1N/A char *undef;
1N/A
1N/A if (SvROK(ST(0))) {
1N/A sv = (SV*)SvRV(ST(0));
1N/A if (!SvOBJECT(sv))
1N/A Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
1N/A pkg = SvSTASH(sv);
1N/A }
1N/A else {
1N/A pkg = gv_stashsv(ST(0), FALSE);
1N/A }
1N/A
1N/A gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
1N/A
1N/A if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
1N/A SV *nsv = sv_newmortal();
1N/A sv_setsv(nsv, sv);
1N/A sv = nsv;
1N/A undef = Nullch;
1N/A }
1N/A else {
1N/A sv = (SV*)&PL_sv_undef;
1N/A undef = "(undef)";
1N/A }
1N/A
1N/A if (items > 1) {
1N/A STRLEN len;
1N/A SV *req = ST(1);
1N/A
1N/A if (undef) {
1N/A if (pkg)
1N/A Perl_croak(aTHX_
1N/A "%s does not define $%s::VERSION--version check failed",
1N/A HvNAME(pkg), HvNAME(pkg));
1N/A else {
1N/A char *str = SvPVx(ST(0), len);
1N/A
1N/A Perl_croak(aTHX_
1N/A "%s defines neither package nor VERSION--version check failed", str);
1N/A }
1N/A }
1N/A if (!SvNIOK(sv) && SvPOK(sv)) {
1N/A char *str = SvPVx(sv,len);
1N/A while (len) {
1N/A --len;
1N/A /* XXX could DWIM "1.2.3" here */
1N/A if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
1N/A break;
1N/A }
1N/A if (len) {
1N/A if (SvNOK(req) && SvPOK(req)) {
1N/A /* they said C<use Foo v1.2.3> and $Foo::VERSION
1N/A * doesn't look like a float: do string compare */
1N/A if (sv_cmp(req,sv) == 1) {
1N/A Perl_croak(aTHX_ "%s v%"VDf" required--"
1N/A "this is only v%"VDf,
1N/A HvNAME(pkg), req, sv);
1N/A }
1N/A goto finish;
1N/A }
1N/A /* they said C<use Foo 1.002_003> and $Foo::VERSION
1N/A * doesn't look like a float: force numeric compare */
1N/A (void)SvUPGRADE(sv, SVt_PVNV);
1N/A SvNVX(sv) = str_to_version(sv);
1N/A SvPOK_off(sv);
1N/A SvNOK_on(sv);
1N/A }
1N/A }
1N/A /* if we get here, we're looking for a numeric comparison,
1N/A * so force the required version into a float, even if they
1N/A * said C<use Foo v1.2.3> */
1N/A if (SvNOK(req) && SvPOK(req)) {
1N/A NV n = SvNV(req);
1N/A req = sv_newmortal();
1N/A sv_setnv(req, n);
1N/A }
1N/A
1N/A if (SvNV(req) > SvNV(sv))
1N/A Perl_croak(aTHX_ "%s version %s required--this is only version %s",
1N/A HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
1N/A }
1N/A
1N/Afinish:
1N/A ST(0) = sv;
1N/A
1N/A XSRETURN(1);
1N/A}
1N/A
1N/AXS(XS_utf8_is_utf8)
1N/A{
1N/A dXSARGS;
1N/A if (items != 1)
1N/A Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
1N/A {
1N/A SV * sv = ST(0);
1N/A {
1N/A if (SvUTF8(sv))
1N/A XSRETURN_YES;
1N/A else
1N/A XSRETURN_NO;
1N/A }
1N/A }
1N/A XSRETURN_EMPTY;
1N/A}
1N/A
1N/AXS(XS_utf8_valid)
1N/A{
1N/A dXSARGS;
1N/A if (items != 1)
1N/A Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
1N/A {
1N/A SV * sv = ST(0);
1N/A {
1N/A STRLEN len;
1N/A char *s = SvPV(sv,len);
1N/A if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
1N/A XSRETURN_YES;
1N/A else
1N/A XSRETURN_NO;
1N/A }
1N/A }
1N/A XSRETURN_EMPTY;
1N/A}
1N/A
1N/AXS(XS_utf8_encode)
1N/A{
1N/A dXSARGS;
1N/A if (items != 1)
1N/A Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
1N/A {
1N/A SV * sv = ST(0);
1N/A
1N/A sv_utf8_encode(sv);
1N/A }
1N/A XSRETURN_EMPTY;
1N/A}
1N/A
1N/AXS(XS_utf8_decode)
1N/A{
1N/A dXSARGS;
1N/A if (items != 1)
1N/A Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
1N/A {
1N/A SV * sv = ST(0);
1N/A bool RETVAL;
1N/A
1N/A RETVAL = sv_utf8_decode(sv);
1N/A ST(0) = boolSV(RETVAL);
1N/A sv_2mortal(ST(0));
1N/A }
1N/A XSRETURN(1);
1N/A}
1N/A
1N/AXS(XS_utf8_upgrade)
1N/A{
1N/A dXSARGS;
1N/A if (items != 1)
1N/A Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
1N/A {
1N/A SV * sv = ST(0);
1N/A STRLEN RETVAL;
1N/A dXSTARG;
1N/A
1N/A RETVAL = sv_utf8_upgrade(sv);
1N/A XSprePUSH; PUSHi((IV)RETVAL);
1N/A }
1N/A XSRETURN(1);
1N/A}
1N/A
1N/AXS(XS_utf8_downgrade)
1N/A{
1N/A dXSARGS;
1N/A if (items < 1 || items > 2)
1N/A Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
1N/A {
1N/A SV * sv = ST(0);
1N/A bool failok;
1N/A bool RETVAL;
1N/A
1N/A if (items < 2)
1N/A failok = 0;
1N/A else {
1N/A failok = (int)SvIV(ST(1));
1N/A }
1N/A
1N/A RETVAL = sv_utf8_downgrade(sv, failok);
1N/A ST(0) = boolSV(RETVAL);
1N/A sv_2mortal(ST(0));
1N/A }
1N/A XSRETURN(1);
1N/A}
1N/A
1N/AXS(XS_utf8_native_to_unicode)
1N/A{
1N/A dXSARGS;
1N/A UV uv = SvUV(ST(0));
1N/A
1N/A if (items > 1)
1N/A Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
1N/A
1N/A ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
1N/A XSRETURN(1);
1N/A}
1N/A
1N/AXS(XS_utf8_unicode_to_native)
1N/A{
1N/A dXSARGS;
1N/A UV uv = SvUV(ST(0));
1N/A
1N/A if (items > 1)
1N/A Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
1N/A
1N/A ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
1N/A XSRETURN(1);
1N/A}
1N/A
1N/AXS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
1N/A{
1N/A dXSARGS;
1N/A SV *sv = SvRV(ST(0));
1N/A if (items == 1) {
1N/A if (SvREADONLY(sv))
1N/A XSRETURN_YES;
1N/A else
1N/A XSRETURN_NO;
1N/A }
1N/A else if (items == 2) {
1N/A if (SvTRUE(ST(1))) {
1N/A SvREADONLY_on(sv);
1N/A XSRETURN_YES;
1N/A }
1N/A else {
1N/A /* I hope you really know what you are doing. */
1N/A SvREADONLY_off(sv);
1N/A XSRETURN_NO;
1N/A }
1N/A }
1N/A XSRETURN_UNDEF; /* Can't happen. */
1N/A}
1N/A
1N/AXS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
1N/A{
1N/A dXSARGS;
1N/A SV *sv = SvRV(ST(0));
1N/A if (items == 1)
1N/A XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
1N/A else if (items == 2) {
1N/A /* I hope you really know what you are doing. */
1N/A SvREFCNT(sv) = SvIV(ST(1));
1N/A XSRETURN_IV(SvREFCNT(sv));
1N/A }
1N/A XSRETURN_UNDEF; /* Can't happen. */
1N/A}
1N/A
1N/AXS(XS_Internals_hv_clear_placehold)
1N/A{
1N/A dXSARGS;
1N/A HV *hv = (HV *) SvRV(ST(0));
1N/A if (items != 1)
1N/A Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
1N/A hv_clear_placeholders(hv);
1N/A XSRETURN(0);
1N/A}
1N/A
1N/AXS(XS_Regexp_DESTROY)
1N/A{
1N/A
1N/A}
1N/A
1N/AXS(XS_PerlIO_get_layers)
1N/A{
1N/A dXSARGS;
1N/A if (items < 1 || items % 2 == 0)
1N/A Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
1N/A#ifdef USE_PERLIO
1N/A {
1N/A SV * sv;
1N/A GV * gv;
1N/A IO * io;
1N/A bool input = TRUE;
1N/A bool details = FALSE;
1N/A
1N/A if (items > 1) {
1N/A SV **svp;
1N/A
1N/A for (svp = MARK + 2; svp <= SP; svp += 2) {
1N/A SV **varp = svp;
1N/A SV **valp = svp + 1;
1N/A STRLEN klen;
1N/A char *key = SvPV(*varp, klen);
1N/A
1N/A switch (*key) {
1N/A case 'i':
1N/A if (klen == 5 && memEQ(key, "input", 5)) {
1N/A input = SvTRUE(*valp);
1N/A break;
1N/A }
1N/A goto fail;
1N/A case 'o':
1N/A if (klen == 6 && memEQ(key, "output", 6)) {
1N/A input = !SvTRUE(*valp);
1N/A break;
1N/A }
1N/A goto fail;
1N/A case 'd':
1N/A if (klen == 7 && memEQ(key, "details", 7)) {
1N/A details = SvTRUE(*valp);
1N/A break;
1N/A }
1N/A goto fail;
1N/A default:
1N/A fail:
1N/A Perl_croak(aTHX_
1N/A "get_layers: unknown argument '%s'",
1N/A key);
1N/A }
1N/A }
1N/A
1N/A SP -= (items - 1);
1N/A }
1N/A
1N/A sv = POPs;
1N/A gv = (GV*)sv;
1N/A
1N/A if (!isGV(sv)) {
1N/A if (SvROK(sv) && isGV(SvRV(sv)))
1N/A gv = (GV*)SvRV(sv);
1N/A else
1N/A gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
1N/A }
1N/A
1N/A if (gv && (io = GvIO(gv))) {
1N/A dTARGET;
1N/A AV* av = PerlIO_get_layers(aTHX_ input ?
1N/A IoIFP(io) : IoOFP(io));
1N/A I32 i;
1N/A I32 last = av_len(av);
1N/A I32 nitem = 0;
1N/A
1N/A for (i = last; i >= 0; i -= 3) {
1N/A SV **namsvp;
1N/A SV **argsvp;
1N/A SV **flgsvp;
1N/A bool namok, argok, flgok;
1N/A
1N/A namsvp = av_fetch(av, i - 2, FALSE);
1N/A argsvp = av_fetch(av, i - 1, FALSE);
1N/A flgsvp = av_fetch(av, i, FALSE);
1N/A
1N/A namok = namsvp && *namsvp && SvPOK(*namsvp);
1N/A argok = argsvp && *argsvp && SvPOK(*argsvp);
1N/A flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1N/A
1N/A if (details) {
1N/A XPUSHs(namok ?
1N/A newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
1N/A XPUSHs(argok ?
1N/A newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
1N/A if (flgok)
1N/A XPUSHi(SvIVX(*flgsvp));
1N/A else
1N/A XPUSHs(&PL_sv_undef);
1N/A nitem += 3;
1N/A }
1N/A else {
1N/A if (namok && argok)
1N/A XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1N/A *namsvp, *argsvp));
1N/A else if (namok)
1N/A XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
1N/A else
1N/A XPUSHs(&PL_sv_undef);
1N/A nitem++;
1N/A if (flgok) {
1N/A IV flags = SvIVX(*flgsvp);
1N/A
1N/A if (flags & PERLIO_F_UTF8) {
1N/A XPUSHs(newSVpvn("utf8", 4));
1N/A nitem++;
1N/A }
1N/A }
1N/A }
1N/A }
1N/A
1N/A SvREFCNT_dec(av);
1N/A
1N/A XSRETURN(nitem);
1N/A }
1N/A }
1N/A#endif
1N/A
1N/A XSRETURN(0);
1N/A}
1N/A
1N/AXS(XS_Internals_hash_seed)
1N/A{
1N/A /* Using dXSARGS would also have dITEM and dSP,
1N/A * which define 2 unused local variables. */
1N/A dMARK; dAX;
1N/A XSRETURN_UV(PERL_HASH_SEED);
1N/A}
1N/A
1N/AXS(XS_Internals_rehash_seed)
1N/A{
1N/A /* Using dXSARGS would also have dITEM and dSP,
1N/A * which define 2 unused local variables. */
1N/A dMARK; dAX;
1N/A XSRETURN_UV(PL_rehash_seed);
1N/A}
1N/A
1N/AXS(XS_Internals_HvREHASH) /* Subject to change */
1N/A{
1N/A dXSARGS;
1N/A if (SvROK(ST(0))) {
1N/A HV *hv = (HV *) SvRV(ST(0));
1N/A if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1N/A if (HvREHASH(hv))
1N/A XSRETURN_YES;
1N/A else
1N/A XSRETURN_NO;
1N/A }
1N/A }
1N/A Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1N/A}