X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/39f7a87036eb8d13c207511143dc7f2e620b3891..d82b684cd82be03d9cc38309478c329f914280b5:/universal.c?ds=sidebyside diff --git a/universal.c b/universal.c index 6b011cf..6b2214d 100644 --- a/universal.c +++ b/universal.c @@ -1,6 +1,7 @@ /* universal.c * - * Copyright (c) 1997-2003, Larry Wall + * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, + * 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. @@ -44,6 +45,9 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, if (strEQ(HvNAME(stash), name)) return &PL_sv_yes; + if (strEQ(name, "UNIVERSAL")) + return &PL_sv_yes; + if (level > 100) Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", HvNAME(stash)); @@ -111,8 +115,7 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, (void)hv_store(hv,name,len,&PL_sv_no,0); } } - - return boolSV(strEQ(name, "UNIVERSAL")); + return &PL_sv_no; } /* @@ -170,6 +173,9 @@ XS(XS_version_numify); XS(XS_version_vcmp); XS(XS_version_boolean); XS(XS_version_noop); +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); @@ -181,6 +187,10 @@ 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) @@ -207,7 +217,10 @@ Perl_boot_core_UNIVERSAL(pTHX) newXS("version::boolean", XS_version_boolean, file); 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); newXS("utf8::encode", XS_utf8_encode, file); newXS("utf8::decode", XS_utf8_decode, file); @@ -219,7 +232,12 @@ Perl_boot_core_UNIVERSAL(pTHX) newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$"); newXSproto("Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, file, "\\%"); - newXS("PerlIO::get_layers", XS_PerlIO_get_layers, file); + newXSproto("PerlIO::get_layers", + 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, "\\%"); } @@ -316,6 +334,8 @@ XS(XS_UNIVERSAL_VERSION) SV *nsv = sv_newmortal(); sv_setsv(nsv, sv); sv = nsv; + if ( !sv_derived_from(sv, "version")) + upg_version(sv); undef = Nullch; } else { @@ -339,19 +359,26 @@ XS(XS_UNIVERSAL_VERSION) "%s defines neither package nor VERSION--version check failed", str); } } - 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 */ + SV *nsv = sv_newmortal(); + sv_setsv(nsv, req); + req = nsv; + upg_version(req); + } - if ( vcmp( SvRV(req), SvRV(sv) ) > 0 ) - Perl_croak(aTHX_ - "%s version %"SVf" required--this is only version %"SVf, - HvNAME(pkg), req, sv); + if ( vcmp( req, sv ) > 0 ) + Perl_croak(aTHX_ "%s version %"SVf" (%"SVf") required--" + "this is only version %"SVf" (%"SVf")", HvNAME(pkg), + vnumify(req),vnormal(req),vnumify(sv),vnormal(sv)); } - ST(0) = sv; + if ( sv_derived_from(sv, "version") ) { + ST(0) = vnumify(sv); + } else { + ST(0) = sv; + } XSRETURN(1); } @@ -363,15 +390,20 @@ XS(XS_version_new) Perl_croak(aTHX_ "Usage: version::new(class, version)"); SP -= items; { -/* char * class = (char *)SvPV_nolen(ST(0)); */ - SV *version = ST(1); + char * class = (char *)SvPV_nolen(ST(0)); + SV *vs = ST(1); + SV *rv; if (items == 3 ) { - char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2))); - version = Perl_newSVpvf(aTHX_ "v%s",vs); + vs = sv_newmortal(); + Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen(ST(2))); } - PUSHs(new_version(version)); + rv = new_version(vs); + if ( strcmp(class,"version") != 0 ) /* inherited new() */ + sv_bless(rv, gv_stashpv(class,TRUE)); + + PUSHs(sv_2mortal(rv)); PUTBACK; return; } @@ -379,62 +411,153 @@ XS(XS_version_new) XS(XS_version_stringify) { - dXSARGS; - if (items < 1) - Perl_croak(aTHX_ "Usage: version::stringify(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"); - -{ - PUSHs(vstringify(lobj)); -} - - PUTBACK; - return; - } + dXSARGS; + if (items < 1) + Perl_croak(aTHX_ "Usage: version::stringify(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"); + + PUSHs(sv_2mortal(vstringify(lobj))); + + PUTBACK; + return; + } } XS(XS_version_numify) { - dXSARGS; - if (items < 1) - Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)"); - SP -= items; - { - SV * lobj; + dXSARGS; + if (items < 1) + Perl_croak(aTHX_ "Usage: version::numify(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"); + + PUSHs(sv_2mortal(vnumify(lobj))); + + PUTBACK; + return; + } +} - if (sv_derived_from(ST(0), "version")) { - SV *tmp = SvRV(ST(0)); - lobj = tmp; - } - else - Perl_croak(aTHX_ "lobj is not of type version"); +XS(XS_version_vcmp) +{ + dXSARGS; + if (items < 1) + Perl_croak(aTHX_ "Usage: version::vcmp(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; + SV *rvs; + SV * robj = ST(1); + IV swap = (IV)SvIV(ST(2)); + + if ( ! sv_derived_from(robj, "version") ) + { + robj = new_version(robj); + } + rvs = SvRV(robj); + + if ( swap ) + { + rs = newSViv(vcmp(rvs,lobj)); + } + else + { + rs = newSViv(vcmp(lobj,rvs)); + } + + PUSHs(sv_2mortal(rs)); + } + + PUTBACK; + return; + } +} +XS(XS_version_boolean) { - PUSHs(vnumify(lobj)); + 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(sv_2mortal(rs)); + } + + PUTBACK; + return; + } } - PUTBACK; - return; - } +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; } -XS(XS_version_vcmp) +XS(XS_version_is_alpha) { dXSARGS; - if (items < 1) - Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)"); + if (items != 1) + Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)"); SP -= items; { - SV * lobj; + SV *lobj; if (sv_derived_from(ST(0), "version")) { SV *tmp = SvRV(ST(0)); @@ -442,103 +565,90 @@ XS(XS_version_vcmp) } else Perl_croak(aTHX_ "lobj is not of type version"); - { - SV *rs; - SV *rvs; - SV * robj = ST(1); - IV swap = (IV)SvIV(ST(2)); - - if ( ! sv_derived_from(robj, "version") ) - { - robj = new_version(robj); - } - rvs = SvRV(robj); - - if ( swap ) - { - rs = newSViv(vcmp(rvs,lobj)); - } + I32 len = av_len((AV *)lobj); + I32 digit = SvIVX(*av_fetch((AV *)lobj, len, 0)); + if ( digit < 0 ) + XSRETURN_YES; else - { - rs = newSViv(vcmp(lobj,rvs)); - } - - PUSHs(rs); + XSRETURN_NO; } - PUTBACK; return; } } -XS(XS_version_boolean) +XS(XS_version_qv) { dXSARGS; - if (items < 1) - Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)"); + if (items != 1) + Perl_croak(aTHX_ "Usage: version::qv(ver)"); 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 * ver = ST(0); + if ( !SvVOK(ver) ) /* only need to do with if not already v-string */ + { + SV *vs = sv_newmortal(); + char *version; + if ( SvNOK(ver) ) /* may get too much accuracy */ + { + char tbuf[64]; + sprintf(tbuf,"%.9"NVgf, SvNVX(ver)); + version = savepv(tbuf); + } + else + { + version = savepv(SvPV_nolen(ver)); + } + (void)scan_version(version,vs,TRUE); + Safefree(version); -{ - SV *rs; - rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) ); - PUSHs(rs); -} + PUSHs(vs); + } + else + { + PUSHs(sv_2mortal(new_version(ver))); + } PUTBACK; return; } } -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"); - +XS(XS_utf8_is_utf8) { - Perl_croak(aTHX_ "operation not supported with version object"); -} - - } - XSRETURN_EMPTY; + dXSARGS; + if (items != 1) + Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)"); + { + SV * sv = ST(0); + { + if (SvUTF8(sv)) + XSRETURN_YES; + else + XSRETURN_NO; + } + } + XSRETURN_EMPTY; } XS(XS_utf8_valid) { - dXSARGS; - 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; - } - } - XSRETURN_EMPTY; + dXSARGS; + 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; + } + } + XSRETURN_EMPTY; } XS(XS_utf8_encode) @@ -671,54 +781,19 @@ 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) { dXSARGS; HV *hv = (HV *) SvRV(ST(0)); + if (items != 1) + Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)"); + hv_clear_placeholders(hv); + XSRETURN(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_undef) { - - /* 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; - } +XS(XS_Regexp_DESTROY) +{ - XSRETURN(0); } XS(XS_PerlIO_get_layers) @@ -726,6 +801,7 @@ XS(XS_PerlIO_get_layers) dXSARGS; if (items < 1 || items % 2 == 0) Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])"); +#ifdef USE_PERLIO { SV * sv; GV * gv; @@ -734,7 +810,6 @@ XS(XS_PerlIO_get_layers) bool details = FALSE; if (items > 1) { - SV **popuntil = MARK + 1; SV **svp; for (svp = MARK + 2; svp <= SP; svp += 2) { @@ -841,7 +916,38 @@ XS(XS_PerlIO_get_layers) XSRETURN(nitem); } } +#endif XSRETURN(0); } +XS(XS_Internals_hash_seed) +{ + /* Using dXSARGS would also have dITEM and dSP, + * which define 2 unused local variables. */ + dMARK; dAX; + XSRETURN_UV(PERL_HASH_SEED); +} + +XS(XS_Internals_rehash_seed) +{ + /* Using dXSARGS would also have dITEM and dSP, + * which define 2 unused local variables. */ + dMARK; dAX; + XSRETURN_UV(PL_rehash_seed); +} + +XS(XS_Internals_HvREHASH) /* Subject to change */ +{ + dXSARGS; + if (SvROK(ST(0))) { + HV *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"); +}