X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9a7034eb2c2d4f0ed795b3c479d700ded086d7e8..f0ab9afb53ef594bb6fb8989153fbfba9762816f:/universal.c diff --git a/universal.c b/universal.c index 15c408d..adfddb5 100644 --- a/universal.c +++ b/universal.c @@ -1,7 +1,7 @@ /* universal.c * - * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, - * by Larry Wall and others + * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, + * 2005, 2006, 2007 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. @@ -14,6 +14,10 @@ * 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" @@ -27,58 +31,65 @@ * 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, +STATIC bool +S_isa_lookup(pTHX_ HV *stash, const char *name, const HV* const name_stash, int len, int level) { + dVAR; AV* av; GV* gv; GV** gvp; - HV* hv = Nullhv; - SV* subgen = Nullsv; + HV* hv = NULL; + SV* subgen = NULL; + const char *hvname; /* A stash/class can go by many names (ie. User == main::User), so we compare the stash itself just in case */ - if (name_stash && (stash == name_stash)) - return &PL_sv_yes; + if (name_stash && ((const HV *)stash == name_stash)) + return TRUE; + + hvname = HvNAME_get(stash); - if (strEQ(HvNAME(stash), name)) - return &PL_sv_yes; + if (strEQ(hvname, name)) + return TRUE; if (strEQ(name, "UNIVERSAL")) - return &PL_sv_yes; + return TRUE; if (level > 100) Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", - HvNAME(stash)); + hvname); - gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE); + gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", FALSE); - if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv)) + if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (subgen = GvSV(gv)) && (hv = GvHV(gv))) { if (SvIV(subgen) == (IV)PL_sub_generation) { - SV* sv; - SV** svp = (SV**)hv_fetch(hv, name, len, FALSE); - if (svp && (sv = *svp) != (SV*)&PL_sv_undef) { - DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n", - name, HvNAME(stash)) ); - return sv; + SV** const svp = (SV**)hv_fetch(hv, name, len, FALSE); + if (svp) { + SV * const sv = *svp; +#ifdef DEBUGGING + if (sv != &PL_sv_undef) + DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n", + name, hvname) ); +#endif + return (sv == &PL_sv_yes); } } else { DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n", - HvNAME(stash)) ); + hvname) ); hv_clear(hv); sv_setiv(subgen, PL_sub_generation); } } - gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); + gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); - if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { + if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (av = GvAV(gv))) { if (!hv || !subgen) { - gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE); + gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", TRUE); gv = *gvp; @@ -97,25 +108,24 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, /* NOTE: No support for tied ISA */ I32 items = AvFILLp(av) + 1; while (items--) { - SV* sv = *svp++; - HV* basestash = gv_stashsv(sv, FALSE); + SV* const sv = *svp++; + HV* const basestash = gv_stashsv(sv, 0); if (!basestash) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Can't locate package %"SVf" for @%s::ISA", - sv, HvNAME(stash)); + "Can't locate package %"SVf" for @%s::ISA", + SVfARG(sv), hvname); continue; } - if (&PL_sv_yes == isa_lookup(basestash, name, name_stash, - len, level + 1)) { + if (isa_lookup(basestash, name, name_stash, len, level + 1)) { (void)hv_store(hv,name,len,&PL_sv_yes,0); - return &PL_sv_yes; + return TRUE; } } (void)hv_store(hv,name,len,&PL_sv_no,0); } } - return &PL_sv_no; + return FALSE; } /* @@ -123,9 +133,9 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, =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. +Returns a boolean indicating whether the SV is derived from the specified class +I. To check derivation at the Perl level, call C as a +normal Perl method. =cut */ @@ -133,47 +143,120 @@ for class names as well as for objects. bool Perl_sv_derived_from(pTHX_ SV *sv, const char *name) { - char *type; + dVAR; HV *stash; - HV *name_stash; - - stash = Nullhv; - type = Nullch; - if (SvGMAGICAL(sv)) - mg_get(sv) ; + SvGETMAGIC(sv); if (SvROK(sv)) { + const char *type; sv = SvRV(sv); type = sv_reftype(sv,0); - if (SvOBJECT(sv)) - stash = SvSTASH(sv); + if (type && strEQ(type,name)) + return TRUE; + stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL; } else { - stash = gv_stashsv(sv, FALSE); + stash = gv_stashsv(sv, 0); } - name_stash = gv_stashpv(name, FALSE); + if (stash) { + HV * const name_stash = gv_stashpv(name, 0); + return isa_lookup(stash, name, name_stash, strlen(name), 0); + } + else + return FALSE; - return (type && strEQ(type,name)) || - (stash && isa_lookup(stash, name, name_stash, strlen(name), 0) - == &PL_sv_yes) - ? TRUE - : FALSE ; } +/* +=for apidoc sv_does + +Returns a boolean indicating whether the SV performs a specific, named role. +The SV can be a Perl object or the name of a Perl class. + +=cut +*/ + #include "XSUB.h" -void XS_UNIVERSAL_isa(pTHX_ CV *cv); -void XS_UNIVERSAL_can(pTHX_ CV *cv); -void XS_UNIVERSAL_VERSION(pTHX_ CV *cv); +bool +Perl_sv_does(pTHX_ SV *sv, const char *name) +{ + const char *classname; + bool does_it; + + dSP; + ENTER; + SAVETMPS; + + SvGETMAGIC(sv); + + if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) + || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) + return FALSE; + + if (sv_isobject(sv)) { + classname = sv_reftype(SvRV(sv),TRUE); + } else { + classname = SvPV_nolen(sv); + } + + if (strEQ(name,classname)) + return TRUE; + + PUSHMARK(SP); + XPUSHs(sv); + XPUSHs(sv_2mortal(newSVpv(name, 0))); + PUTBACK; + + call_method("isa", G_SCALAR); + SPAGAIN; + + does_it = SvTRUE( TOPs ); + FREETMPS; + LEAVE; + + return does_it; +} + +regexp * +Perl_get_re_arg( pTHX_ SV *sv, U32 flags, MAGIC **mgp) { + MAGIC *mg; + if (sv) { + if (SvMAGICAL(sv)) + mg_get(sv); + if (SvROK(sv) && + (sv = (SV*)SvRV(sv)) && /* assign deliberate */ + SvTYPE(sv) == SVt_PVMG && + (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */ + { + if (mgp) *mgp = mg; + return (regexp *)mg->mg_obj; + } + } + if (mgp) *mgp = NULL; + return ((flags && PL_curpm) ? PM_GETRE(PL_curpm) : NULL); +} + + +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_DOES(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); @@ -188,14 +271,25 @@ 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); +XS(XS_Internals_inc_sub_generation); +XS(XS_re_is_regexp); +XS(XS_re_regname); +XS(XS_re_regnames); +XS(XS_re_regnames_iterinit); +XS(XS_re_regnames_iternext); +XS(XS_re_regnames_count); void Perl_boot_core_UNIVERSAL(pTHX) { - char *file = __FILE__; + dVAR; + static const char file[] = __FILE__; newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); + newXS("UNIVERSAL::DOES", XS_UNIVERSAL_DOES, file); newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file); { /* register the overloading (type 'A') magic */ @@ -207,6 +301,7 @@ Perl_boot_core_UNIVERSAL(pTHX) newXS("version::stringify", XS_version_stringify, file); newXS("version::(0+", XS_version_numify, file); newXS("version::numify", XS_version_numify, file); + newXS("version::normal", XS_version_normal, file); newXS("version::(cmp", XS_version_vcmp, file); newXS("version::(<=>", XS_version_vcmp, file); newXS("version::vcmp", XS_version_vcmp, file); @@ -215,6 +310,7 @@ Perl_boot_core_UNIVERSAL(pTHX) newXS("version::(nomethod", XS_version_noop, file); newXS("version::noop", XS_version_noop, file); newXS("version::is_alpha", XS_version_is_alpha, file); + newXS("version::qv", XS_version_qv, file); } newXS("utf8::is_utf8", XS_utf8_is_utf8, file); newXS("utf8::valid", XS_utf8_valid, file); @@ -232,56 +328,66 @@ Perl_boot_core_UNIVERSAL(pTHX) XS_PerlIO_get_layers, file, "*;@"); newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file); newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, ""); + newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, ""); + newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%"); + newXSproto("Internals::inc_sub_generation",XS_Internals_inc_sub_generation, + file, ""); + newXSproto("re::is_regexp", XS_re_is_regexp, file, "$"); + newXSproto("re::regname", XS_re_regname, file, ";$$"); + newXSproto("re::regnames", XS_re_regnames, file, ";$"); + newXSproto("re::regnames_iterinit", XS_re_regnames_iterinit, file, ""); + newXSproto("re::regnames_iternext", XS_re_regnames_iternext, file, ";$"); + newXSproto("re::regnames_count", XS_re_regnames_count, file, ""); } XS(XS_UNIVERSAL_isa) { + dVAR; dXSARGS; - SV *sv; - char *name; - STRLEN n_a; + PERL_UNUSED_ARG(cv); if (items != 2) Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)"); + else { + SV * const sv = ST(0); + const char *name; - sv = ST(0); + SvGETMAGIC(sv); - if (SvGMAGICAL(sv)) - mg_get(sv); + if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) + || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) + XSRETURN_UNDEF; - if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) - || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) - XSRETURN_UNDEF; + name = SvPV_nolen_const(ST(1)); - name = (char *)SvPV(ST(1),n_a); - - ST(0) = boolSV(sv_derived_from(sv, name)); - XSRETURN(1); + ST(0) = boolSV(sv_derived_from(sv, name)); + XSRETURN(1); + } } XS(XS_UNIVERSAL_can) { + dVAR; dXSARGS; SV *sv; - char *name; + const char *name; SV *rv; HV *pkg = NULL; - STRLEN n_a; + PERL_UNUSED_ARG(cv); if (items != 2) Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)"); sv = ST(0); - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) XSRETURN_UNDEF; - name = (char *)SvPV(ST(1),n_a); + name = SvPV_nolen_const(ST(1)); rv = &PL_sv_undef; if (SvROK(sv)) { @@ -290,11 +396,11 @@ XS(XS_UNIVERSAL_can) pkg = SvSTASH(sv); } else { - pkg = gv_stashsv(sv, FALSE); + pkg = gv_stashsv(sv, 0); } if (pkg) { - GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE); + GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE); if (gv && isGV(gv)) rv = sv_2mortal(newRV((SV*)GvCV(gv))); } @@ -303,14 +409,36 @@ XS(XS_UNIVERSAL_can) XSRETURN(1); } +XS(XS_UNIVERSAL_DOES) +{ + dVAR; + dXSARGS; + PERL_UNUSED_ARG(cv); + + if (items != 2) + Perl_croak(aTHX_ "Usage: invocant->does(kind)"); + else { + SV * const sv = ST(0); + const char *name; + + name = SvPV_nolen_const(ST(1)); + if (sv_does( sv, name )) + XSRETURN_YES; + + XSRETURN_NO; + } +} + XS(XS_UNIVERSAL_VERSION) { + dVAR; dXSARGS; HV *pkg; GV **gvp; GV *gv; SV *sv; - char *undef; + const char *undef; + PERL_UNUSED_ARG(cv); if (SvROK(ST(0))) { sv = (SV*)SvRV(ST(0)); @@ -319,16 +447,18 @@ XS(XS_UNIVERSAL_VERSION) pkg = SvSTASH(sv); } else { - pkg = gv_stashsv(ST(0), FALSE); + pkg = gv_stashsv(ST(0), 0); } - gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**); + gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL; - if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) { - SV *nsv = sv_newmortal(); + if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) { + SV * const nsv = sv_newmortal(); sv_setsv(nsv, sv); sv = nsv; - undef = Nullch; + if ( !sv_derived_from(sv, "version")) + upg_version(sv, FALSE); + undef = NULL; } else { sv = (SV*)&PL_sv_undef; @@ -336,54 +466,82 @@ XS(XS_UNIVERSAL_VERSION) } if (items > 1) { - STRLEN len; SV *req = ST(1); if (undef) { - if (pkg) - Perl_croak(aTHX_ - "%s does not define $%s::VERSION--version check failed", - HvNAME(pkg), HvNAME(pkg)); - else { - char *str = SvPVx(ST(0), len); - - Perl_croak(aTHX_ - "%s defines neither package nor VERSION--version check failed", str); + if (pkg) { + const char * const name = HvNAME_get(pkg); + Perl_croak(aTHX_ + "%s does not define $%s::VERSION--version check failed", + name, name); + } else { + Perl_croak(aTHX_ + "%s defines neither package nor VERSION--version check failed", + SvPVx_nolen_const(ST(0)) ); } } - if ( !sv_derived_from(sv, "version")) - sv = new_version(sv); - if ( !sv_derived_from(req, "version")) - req = new_version(req); + if ( !sv_derived_from(req, "version")) { + /* req may very well be R/O, so create a new object */ + req = sv_2mortal( new_version(req) ); + } + + if ( vcmp( req, sv ) > 0 ) { + if ( hv_exists((HV*)SvRV(req), "qv", 2 ) ) { + Perl_croak(aTHX_ "%s version %"SVf" required--" + "this is only version %"SVf"", HvNAME_get(pkg), + SVfARG(vnormal(req)), + SVfARG(vnormal(sv))); + } else { + Perl_croak(aTHX_ "%s version %"SVf" required--" + "this is only version %"SVf"", HvNAME_get(pkg), + SVfARG(vnumify(req)), + SVfARG(vnumify(sv))); + } + } - if ( vcmp( SvRV(req), SvRV(sv) ) > 0 ) - Perl_croak(aTHX_ - "%s version %"SVf" required--this is only version %"SVf, - HvNAME(pkg), req, sv); } - ST(0) = sv; + if ( SvOK(sv) && sv_derived_from(sv, "version") ) { + ST(0) = vnumify(sv); + } else { + ST(0) = sv; + } XSRETURN(1); } XS(XS_version_new) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items > 3) Perl_croak(aTHX_ "Usage: version::new(class, version)"); SP -= items; { -/* char * class = (char *)SvPV_nolen(ST(0)); */ - SV *version = ST(1); - if (items == 3 ) - { - char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2))); - version = Perl_newSVpvf(aTHX_ "v%s",vs); + SV *vs = ST(1); + SV *rv; + const char * const classname = + sv_isobject(ST(0)) /* get the class if called as an object method */ + ? HvNAME(SvSTASH(SvRV(ST(0)))) + : (char *)SvPV_nolen(ST(0)); + + if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */ + /* create empty object */ + vs = sv_newmortal(); + sv_setpvn(vs,"",0); + } + else if ( items == 3 ) { + vs = sv_newmortal(); + Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2))); } - PUSHs(new_version(version)); + rv = new_version(vs); + if ( strcmp(classname,"version") != 0 ) /* inherited new() */ + sv_bless(rv, gv_stashpv(classname, GV_ADD)); + + PUSHs(sv_2mortal(rv)); PUTBACK; return; } @@ -391,7 +549,9 @@ XS(XS_version_new) XS(XS_version_stringify) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items < 1) Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)"); SP -= items; @@ -399,15 +559,12 @@ XS(XS_version_stringify) SV * lobj; if (sv_derived_from(ST(0), "version")) { - SV *tmp = SvRV(ST(0)); - lobj = tmp; + lobj = SvRV(ST(0)); } else Perl_croak(aTHX_ "lobj is not of type version"); - { - PUSHs(vstringify(lobj)); - } + PUSHs(sv_2mortal(vstringify(lobj))); PUTBACK; return; @@ -416,7 +573,9 @@ XS(XS_version_stringify) XS(XS_version_numify) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items < 1) Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)"); SP -= items; @@ -424,15 +583,36 @@ XS(XS_version_numify) SV * lobj; if (sv_derived_from(ST(0), "version")) { - SV *tmp = SvRV(ST(0)); - lobj = tmp; + lobj = SvRV(ST(0)); } else Perl_croak(aTHX_ "lobj is not of type version"); - { - PUSHs(vnumify(lobj)); + PUSHs(sv_2mortal(vnumify(lobj))); + + PUTBACK; + return; + } +} + +XS(XS_version_normal) +{ + dVAR; + dXSARGS; + PERL_UNUSED_ARG(cv); + if (items < 1) + Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)"); + SP -= items; + { + SV * lobj; + + if (sv_derived_from(ST(0), "version")) { + lobj = SvRV(ST(0)); } + else + Perl_croak(aTHX_ "lobj is not of type version"); + + PUSHs(sv_2mortal(vnormal(lobj))); PUTBACK; return; @@ -441,7 +621,9 @@ XS(XS_version_numify) XS(XS_version_vcmp) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items < 1) Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)"); SP -= items; @@ -449,8 +631,7 @@ XS(XS_version_vcmp) SV * lobj; if (sv_derived_from(ST(0), "version")) { - SV *tmp = SvRV(ST(0)); - lobj = tmp; + lobj = SvRV(ST(0)); } else Perl_croak(aTHX_ "lobj is not of type version"); @@ -459,7 +640,7 @@ XS(XS_version_vcmp) SV *rs; SV *rvs; SV * robj = ST(1); - IV swap = (IV)SvIV(ST(2)); + const IV swap = (IV)SvIV(ST(2)); if ( ! sv_derived_from(robj, "version") ) { @@ -476,7 +657,7 @@ XS(XS_version_vcmp) rs = newSViv(vcmp(lobj,rvs)); } - PUSHs(rs); + PUSHs(sv_2mortal(rs)); } PUTBACK; @@ -486,77 +667,81 @@ XS(XS_version_vcmp) XS(XS_version_boolean) { - dXSARGS; - if (items < 1) - Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)"); - SP -= items; - { - SV * lobj; - - if (sv_derived_from(ST(0), "version")) { - SV *tmp = SvRV(ST(0)); - lobj = tmp; - } - else - Perl_croak(aTHX_ "lobj is not of type version"); - - { - SV *rs; - rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) ); - PUSHs(rs); - } - - PUTBACK; - return; - } + dVAR; + dXSARGS; + PERL_UNUSED_ARG(cv); + if (items < 1) + Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)"); + SP -= items; + if (sv_derived_from(ST(0), "version")) { + SV * const lobj = SvRV(ST(0)); + SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) ); + PUSHs(sv_2mortal(rs)); + PUTBACK; + return; + } + else + Perl_croak(aTHX_ "lobj is not of type version"); } XS(XS_version_noop) { - dXSARGS; - if (items < 1) - Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)"); - { - SV * lobj; - - if (sv_derived_from(ST(0), "version")) { - SV *tmp = SvRV(ST(0)); - lobj = tmp; - } - else - Perl_croak(aTHX_ "lobj is not of type version"); - - { - Perl_croak(aTHX_ "operation not supported with version object"); - } - - } - XSRETURN_EMPTY; + dVAR; + dXSARGS; + PERL_UNUSED_ARG(cv); + if (items < 1) + Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)"); + if (sv_derived_from(ST(0), "version")) + 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) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)"); SP -= items; - { - SV *lobj; - - if (sv_derived_from(ST(0), "version")) { - SV *tmp = SvRV(ST(0)); - lobj = tmp; - } - else - Perl_croak(aTHX_ "lobj is not of type version"); -{ - I32 len = av_len((AV *)lobj); - I32 digit = SvIVX(*av_fetch((AV *)lobj, len, 0)); - if ( digit < 0 ) - XSRETURN_YES; + if (sv_derived_from(ST(0), "version")) { + SV * const lobj = ST(0); + if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) ) + XSRETURN_YES; + else + XSRETURN_NO; + PUTBACK; + return; + } else - XSRETURN_NO; + Perl_croak(aTHX_ "lobj is not of type version"); } + +XS(XS_version_qv) +{ + dVAR; + dXSARGS; + PERL_UNUSED_ARG(cv); + if (items != 1) + Perl_croak(aTHX_ "Usage: version::qv(ver)"); + SP -= items; + { + SV * ver = ST(0); + if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */ + SV * const rv = sv_newmortal(); + sv_setsv(rv,ver); /* make a duplicate */ + upg_version(rv, TRUE); + PUSHs(rv); + } + else + { + PUSHs(sv_2mortal(new_version(ver))); + } + PUTBACK; return; } @@ -564,63 +749,61 @@ XS(XS_version_is_alpha) XS(XS_utf8_is_utf8) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)"); - { - SV * sv = ST(0); - { - if (SvUTF8(sv)) - XSRETURN_YES; - else - XSRETURN_NO; - } + else { + const SV * const sv = ST(0); + if (SvUTF8(sv)) + XSRETURN_YES; + else + XSRETURN_NO; } XSRETURN_EMPTY; } XS(XS_utf8_valid) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: utf8::valid(sv)"); - { - SV * sv = ST(0); - { - STRLEN len; - char *s = SvPV(sv,len); - if (!SvUTF8(sv) || is_utf8_string((U8*)s,len)) - XSRETURN_YES; - else - XSRETURN_NO; - } - } + else { + SV * const sv = ST(0); + STRLEN len; + const char * const s = SvPV_const(sv,len); + if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len)) + XSRETURN_YES; + else + XSRETURN_NO; + } XSRETURN_EMPTY; } XS(XS_utf8_encode) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: utf8::encode(sv)"); - { - SV * sv = ST(0); - - sv_utf8_encode(sv); - } + sv_utf8_encode(ST(0)); XSRETURN_EMPTY; } XS(XS_utf8_decode) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: utf8::decode(sv)"); - { - SV * sv = ST(0); - bool RETVAL; - - RETVAL = sv_utf8_decode(sv); + else { + SV * const sv = ST(0); + const bool RETVAL = sv_utf8_decode(sv); ST(0) = boolSV(RETVAL); sv_2mortal(ST(0)); } @@ -629,11 +812,13 @@ XS(XS_utf8_decode) XS(XS_utf8_upgrade) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)"); - { - SV * sv = ST(0); + else { + SV * const sv = ST(0); STRLEN RETVAL; dXSTARG; @@ -645,21 +830,16 @@ XS(XS_utf8_upgrade) XS(XS_utf8_downgrade) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items < 1 || items > 2) Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)"); - { - SV * sv = ST(0); - bool failok; - bool RETVAL; - - if (items < 2) - failok = 0; - else { - failok = (int)SvIV(ST(1)); - } + else { + SV * const sv = ST(0); + const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1)); + const bool RETVAL = sv_utf8_downgrade(sv, failok); - RETVAL = sv_utf8_downgrade(sv, failok); ST(0) = boolSV(RETVAL); sv_2mortal(ST(0)); } @@ -668,8 +848,10 @@ XS(XS_utf8_downgrade) XS(XS_utf8_native_to_unicode) { + dVAR; dXSARGS; - UV uv = SvUV(ST(0)); + const UV uv = SvUV(ST(0)); + PERL_UNUSED_ARG(cv); if (items > 1) Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)"); @@ -680,8 +862,10 @@ XS(XS_utf8_native_to_unicode) XS(XS_utf8_unicode_to_native) { + dVAR; dXSARGS; - UV uv = SvUV(ST(0)); + const UV uv = SvUV(ST(0)); + PERL_UNUSED_ARG(cv); if (items > 1) Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)"); @@ -692,8 +876,11 @@ XS(XS_utf8_unicode_to_native) XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ { + dVAR; dXSARGS; - SV *sv = SvRV(ST(0)); + SV * const sv = SvRV(ST(0)); + PERL_UNUSED_ARG(cv); + if (items == 1) { if (SvREADONLY(sv)) XSRETURN_YES; @@ -716,8 +903,11 @@ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ { + dVAR; dXSARGS; - SV *sv = SvRV(ST(0)); + SV * const sv = SvRV(ST(0)); + PERL_UNUSED_ARG(cv); + if (items == 1) XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */ else if (items == 2) { @@ -728,64 +918,32 @@ XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ XSRETURN_UNDEF; /* Can't happen. */ } -/* Maybe this should return the number of placeholders found in scalar context, - and a list of them in list context. */ XS(XS_Internals_hv_clear_placehold) { + dVAR; dXSARGS; - HV *hv = (HV *) SvRV(ST(0)); - - /* I don't care how many parameters were passed in, but I want to avoid - the unused variable warning. */ - - items = (I32)HvPLACEHOLDERS(hv); - - if (items) { - HE *entry; - I32 riter = HvRITER(hv); - HE *eiter = HvEITER(hv); - hv_iterinit(hv); - /* This may look suboptimal with the items *after* the iternext, but - it's quite deliberate. We only get here with items==0 if we've - just deleted the last placeholder in the hash. If we've just done - that then it means that the hash is in lazy delete mode, and the - HE is now only referenced in our iterator. If we just quit the loop - and discarded our iterator then the HE leaks. So we do the && the - other way to ensure iternext is called just one more time, which - has the side effect of triggering the lazy delete. */ - while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS)) - && items) { - SV *val = hv_iterval(hv, entry); - - if (val == &PL_sv_placeholder) { - - /* It seems that I have to go back in the front of the hash - API to delete a hash, even though I have a HE structure - pointing to the very entry I want to delete, and could hold - onto the previous HE that points to it. And it's easier to - go in with SVs as I can then specify the precomputed hash, - and don't have fun and games with utf8 keys. */ - SV *key = hv_iterkeysv(entry); - - hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry)); - items--; - } - } - HvRITER(hv) = riter; - HvEITER(hv) = eiter; - } + PERL_UNUSED_ARG(cv); - XSRETURN(0); + if (items != 1) + Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)"); + else { + HV * const hv = (HV *) SvRV(ST(0)); + hv_clear_placeholders(hv); + XSRETURN(0); + } } XS(XS_Regexp_DESTROY) { - + PERL_UNUSED_CONTEXT; + PERL_UNUSED_ARG(cv); } XS(XS_PerlIO_get_layers) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items < 1 || items % 2 == 0) Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])"); #ifdef USE_PERLIO @@ -797,13 +955,12 @@ XS(XS_PerlIO_get_layers) bool details = FALSE; if (items > 1) { - SV **svp; - + SV * const *svp; for (svp = MARK + 2; svp <= SP; svp += 2) { - SV **varp = svp; - SV **valp = svp + 1; + SV * const * const varp = svp; + SV * const * const valp = svp + 1; STRLEN klen; - char *key = SvPV(*varp, klen); + const char * const key = SvPV_const(*varp, klen); switch (*key) { case 'i': @@ -841,37 +998,34 @@ XS(XS_PerlIO_get_layers) if (!isGV(sv)) { if (SvROK(sv) && isGV(SvRV(sv))) gv = (GV*)SvRV(sv); - else - gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO); + else if (SvPOKp(sv)) + gv = gv_fetchsv(sv, 0, SVt_PVIO); } if (gv && (io = GvIO(gv))) { dTARGET; - AV* av = PerlIO_get_layers(aTHX_ input ? + AV* const av = PerlIO_get_layers(aTHX_ input ? IoIFP(io) : IoOFP(io)); I32 i; - I32 last = av_len(av); + const I32 last = av_len(av); I32 nitem = 0; for (i = last; i >= 0; i -= 3) { - SV **namsvp; - SV **argsvp; - SV **flgsvp; - bool namok, argok, flgok; + SV * const * const namsvp = av_fetch(av, i - 2, FALSE); + SV * const * const argsvp = av_fetch(av, i - 1, FALSE); + SV * const * const flgsvp = av_fetch(av, i, FALSE); - namsvp = av_fetch(av, i - 2, FALSE); - argsvp = av_fetch(av, i - 1, FALSE); - flgsvp = av_fetch(av, i, FALSE); - - namok = namsvp && *namsvp && SvPOK(*namsvp); - argok = argsvp && *argsvp && SvPOK(*argsvp); - flgok = flgsvp && *flgsvp && SvIOK(*flgsvp); + const bool namok = namsvp && *namsvp && SvPOK(*namsvp); + const bool argok = argsvp && *argsvp && SvPOK(*argsvp); + const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp); if (details) { - XPUSHs(namok ? - newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef); - XPUSHs(argok ? - newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef); + 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 @@ -881,17 +1035,19 @@ XS(XS_PerlIO_get_layers) else { if (namok && argok) XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")", - *namsvp, *argsvp)); + SVfARG(*namsvp), + SVfARG(*argsvp))); else if (namok) - XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp)); + XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, + SVfARG(*namsvp))); else XPUSHs(&PL_sv_undef); nitem++; if (flgok) { - IV flags = SvIVX(*flgsvp); + const IV flags = SvIVX(*flgsvp); if (flags & PERLIO_F_UTF8) { - XPUSHs(newSVpvn("utf8", 4)); + XPUSHs(newSVpvs("utf8")); nitem++; } } @@ -910,7 +1066,284 @@ XS(XS_PerlIO_get_layers) XS(XS_Internals_hash_seed) { + dVAR; + /* 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) +{ + dVAR; + /* 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(PL_rehash_seed); +} + +XS(XS_Internals_HvREHASH) /* Subject to change */ +{ + dVAR; dXSARGS; - XSRETURN_UV(PL_hash_seed); + PERL_UNUSED_ARG(cv); + if (SvROK(ST(0))) { + const HV * const hv = (HV *) SvRV(ST(0)); + if (items == 1 && SvTYPE(hv) == SVt_PVHV) { + if (HvREHASH(hv)) + XSRETURN_YES; + else + XSRETURN_NO; + } + } + Perl_croak(aTHX_ "Internals::HvREHASH $hashref"); +} + +XS(XS_Internals_inc_sub_generation) +{ + dVAR; + /* Using dXSARGS would also have dITEM and dSP, + * which define 2 unused local variables. */ + dAXMARK; + PERL_UNUSED_ARG(cv); + PERL_UNUSED_VAR(mark); + ++PL_sub_generation; + XSRETURN_EMPTY; } +XS(XS_re_is_regexp) +{ + dVAR; + dXSARGS; + if (items != 1) + Perl_croak(aTHX_ "Usage: %s(%s)", "re::is_regexp", "sv"); + PERL_UNUSED_VAR(cv); /* -W */ + PERL_UNUSED_VAR(ax); /* -Wall */ + SP -= items; + { + SV * sv = ST(0); + if ( Perl_get_re_arg( aTHX_ sv, 0, NULL ) ) + { + XSRETURN_YES; + } else { + XSRETURN_NO; + } + /* NOTREACHED */ + PUTBACK; + return; + } +} + +XS(XS_re_regname) +{ + + dVAR; + dXSARGS; + if (items < 1 || items > 2) + Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "name[, all ]"); + PERL_UNUSED_VAR(cv); /* -W */ + PERL_UNUSED_VAR(ax); /* -Wall */ + SP -= items; + { + SV * sv = ST(0); + SV * all; + regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + SV *bufs = NULL; + + if (items < 2) + all = NULL; + else { + all = ST(1); + } + { + if (SvPOK(sv) && re && re->paren_names) { + bufs = CALLREG_NAMEDBUF(re,sv,all && SvTRUE(all)); + if (bufs) { + if (all && SvTRUE(all)) + XPUSHs(newRV(bufs)); + else + XPUSHs(SvREFCNT_inc(bufs)); + XSRETURN(1); + } + } + XSRETURN_UNDEF; + } + PUTBACK; + return; + } +} + +XS(XS_re_regnames) +{ + dVAR; + dXSARGS; + if (items < 0 || items > 1) + Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "[all]"); + PERL_UNUSED_VAR(cv); /* -W */ + PERL_UNUSED_VAR(ax); /* -Wall */ + SP -= items; + { + SV * all; + regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + IV count = 0; + + if (items < 1) + all = NULL; + else { + all = ST(0); + } + { + if (re && re->paren_names) { + HV *hv= re->paren_names; + (void)hv_iterinit(hv); + while (1) { + HE *temphe = hv_iternext_flags(hv,0); + if (temphe) { + IV i; + IV parno = 0; + SV* sv_dat = HeVAL(temphe); + I32 *nums = (I32*)SvPVX(sv_dat); + for ( i = 0; i < SvIVX(sv_dat); i++ ) { + if ((I32)(re->lastcloseparen) >= nums[i] && + re->offs[nums[i]].start != -1 && + re->offs[nums[i]].end != -1) + { + parno = nums[i]; + break; + } + } + if (parno || (all && SvTRUE(all))) { + STRLEN len; + char *pv = HePV(temphe, len); + if ( GIMME_V == G_ARRAY ) + XPUSHs(newSVpvn(pv,len)); + count++; + } + } else { + break; + } + } + } + if ( GIMME_V == G_ARRAY ) + XSRETURN(count); + else + XSRETURN_UNDEF; + } + PUTBACK; + return; + } +} + + +XS(XS_re_regnames_iterinit) +{ + dVAR; + dXSARGS; + if (items != 0) + Perl_croak(aTHX_ "Usage: re::regnames_iterinit()"); + PERL_UNUSED_VAR(cv); /* -W */ + PERL_UNUSED_VAR(ax); /* -Wall */ + SP -= items; + { + regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + if (re && re->paren_names) { + (void)hv_iterinit(re->paren_names); + XPUSHs(newSViv(HvTOTALKEYS(re->paren_names))); + } else { + XSRETURN_UNDEF; + } + PUTBACK; + return; + } +} + + +XS(XS_re_regnames_iternext) +{ + dVAR; + dXSARGS; + if (items < 0 || items > 1) + Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iternext", "[all]"); + PERL_UNUSED_VAR(cv); /* -W */ + PERL_UNUSED_VAR(ax); /* -Wall */ + SP -= items; + { + SV * all; + regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + + if (items < 1) + all = NULL; + else { + all = ST(0); + } + if (re && re->paren_names) { + HV *hv= re->paren_names; + while (1) { + HE *temphe = hv_iternext_flags(hv,0); + if (temphe) { + IV i; + IV parno = 0; + SV* sv_dat = HeVAL(temphe); + I32 *nums = (I32*)SvPVX(sv_dat); + for ( i = 0; i < SvIVX(sv_dat); i++ ) { + if ((I32)(re->lastcloseparen) >= nums[i] && + re->offs[nums[i]].start != -1 && + re->offs[nums[i]].end != -1) + { + parno = nums[i]; + break; + } + } + if (parno || (all && SvTRUE(all))) { + STRLEN len; + char *pv = HePV(temphe, len); + XPUSHs(newSVpvn(pv,len)); + XSRETURN(1); + } + } else { + break; + } + } + } + XSRETURN_UNDEF; + PUTBACK; + return; + } +} + + +XS(XS_re_regnames_count) +{ + regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + dVAR; + dXSARGS; + + if (items != 0) + Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", ""); + PERL_UNUSED_VAR(cv); /* -W */ + PERL_UNUSED_VAR(ax); /* -Wall */ + SP -= items; + + if (re && re->paren_names) { + XPUSHs(newSViv(HvTOTALKEYS(re->paren_names))); + } else { + XSRETURN_UNDEF; + } + PUTBACK; + return; +} + + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */