X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=universal.c;h=a90ba5d58f1b229b99498f2c0e9c2b5332c50f05;hb=55082927c3a5e85aa9f9d6c8e76cacf11d232232;hp=22be54f128f0266789d454ad3c3730094064cc48;hpb=41be1fbddbbc49a5c34acad74f2905b11dd0ced0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/universal.c b/universal.c index 22be54f..a90ba5d 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, 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" @@ -45,6 +49,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)); @@ -112,8 +119,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; } /* @@ -131,7 +137,7 @@ for class names as well as for objects. bool Perl_sv_derived_from(pTHX_ SV *sv, const char *name) { - char *type; + const char *type; HV *stash; HV *name_stash; @@ -171,6 +177,8 @@ 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); @@ -184,11 +192,14 @@ 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) { - char *file = __FILE__; + const char file[] = __FILE__; newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); @@ -210,6 +221,8 @@ 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); @@ -226,6 +239,9 @@ Perl_boot_core_UNIVERSAL(pTHX) 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, "\\%"); } @@ -233,8 +249,9 @@ XS(XS_UNIVERSAL_isa) { dXSARGS; SV *sv; - char *name; + const char *name; STRLEN n_a; + (void)cv; if (items != 2) Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)"); @@ -248,7 +265,7 @@ XS(XS_UNIVERSAL_isa) || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) XSRETURN_UNDEF; - name = (char *)SvPV(ST(1),n_a); + name = (const char *)SvPV(ST(1),n_a); ST(0) = boolSV(sv_derived_from(sv, name)); XSRETURN(1); @@ -258,10 +275,11 @@ XS(XS_UNIVERSAL_can) { dXSARGS; SV *sv; - char *name; + const char *name; SV *rv; HV *pkg = NULL; STRLEN n_a; + (void)cv; if (items != 2) Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)"); @@ -275,7 +293,7 @@ XS(XS_UNIVERSAL_can) || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) XSRETURN_UNDEF; - name = (char *)SvPV(ST(1),n_a); + name = (const char *)SvPV(ST(1),n_a); rv = &PL_sv_undef; if (SvROK(sv)) { @@ -304,7 +322,8 @@ XS(XS_UNIVERSAL_VERSION) GV **gvp; GV *gv; SV *sv; - char *undef; + const char *undef; + (void)cv; if (SvROK(ST(0))) { sv = (SV*)SvRV(ST(0)); @@ -322,6 +341,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,25 +360,32 @@ XS(XS_UNIVERSAL_VERSION) "%s does not define $%s::VERSION--version check failed", HvNAME(pkg), HvNAME(pkg)); else { - char *str = SvPVx(ST(0), len); + const char *str = SvPVx(ST(0), len); Perl_croak(aTHX_ "%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 ( SvOK(sv) && sv_derived_from(sv, "version") ) { + ST(0) = vnumify(sv); + } else { + ST(0) = sv; + } XSRETURN(1); } @@ -365,19 +393,25 @@ XS(XS_UNIVERSAL_VERSION) XS(XS_version_new) { dXSARGS; + (void)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); + const char *classname = 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(classname,"version") != 0 ) /* inherited new() */ + sv_bless(rv, gv_stashpv(classname,TRUE)); + + PUSHs(sv_2mortal(rv)); PUTBACK; return; } @@ -386,6 +420,7 @@ XS(XS_version_new) XS(XS_version_stringify) { dXSARGS; + (void)cv; if (items < 1) Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)"); SP -= items; @@ -399,9 +434,7 @@ XS(XS_version_stringify) else Perl_croak(aTHX_ "lobj is not of type version"); - { - PUSHs(vstringify(lobj)); - } + PUSHs(sv_2mortal(vstringify(lobj))); PUTBACK; return; @@ -411,6 +444,7 @@ XS(XS_version_stringify) XS(XS_version_numify) { dXSARGS; + (void)cv; if (items < 1) Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)"); SP -= items; @@ -424,9 +458,7 @@ XS(XS_version_numify) else Perl_croak(aTHX_ "lobj is not of type version"); - { - PUSHs(vnumify(lobj)); - } + PUSHs(sv_2mortal(vnumify(lobj))); PUTBACK; return; @@ -436,6 +468,7 @@ XS(XS_version_numify) XS(XS_version_vcmp) { dXSARGS; + (void)cv; if (items < 1) Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)"); SP -= items; @@ -470,7 +503,7 @@ XS(XS_version_vcmp) rs = newSViv(vcmp(lobj,rvs)); } - PUSHs(rs); + PUSHs(sv_2mortal(rs)); } PUTBACK; @@ -481,6 +514,7 @@ XS(XS_version_vcmp) XS(XS_version_boolean) { dXSARGS; + (void)cv; if (items < 1) Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)"); SP -= items; @@ -488,6 +522,7 @@ XS(XS_version_boolean) SV * lobj; if (sv_derived_from(ST(0), "version")) { + /* XXX If tmp serves a purpose, explain it. */ SV *tmp = SvRV(ST(0)); lobj = tmp; } @@ -497,7 +532,7 @@ XS(XS_version_boolean) { SV *rs; rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) ); - PUSHs(rs); + PUSHs(sv_2mortal(rs)); } PUTBACK; @@ -508,6 +543,7 @@ XS(XS_version_boolean) XS(XS_version_noop) { dXSARGS; + (void)cv; if (items < 1) Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)"); { @@ -528,13 +564,82 @@ XS(XS_version_noop) XSRETURN_EMPTY; } +XS(XS_version_is_alpha) +{ + dXSARGS; + (void)cv; + if (items != 1) + Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)"); + SP -= items; + { + SV *lobj; + + if (sv_derived_from(ST(0), "version")) { + /* XXX If tmp serves a purpose, explain it. */ + SV *tmp = SvRV(ST(0)); + lobj = tmp; + } + else + Perl_croak(aTHX_ "lobj is not of type version"); +{ + const I32 len = av_len((AV *)lobj); + const I32 digit = SvIVX(*av_fetch((AV *)lobj, len, 0)); + if ( digit < 0 ) + XSRETURN_YES; + else + XSRETURN_NO; +} + PUTBACK; + return; + } +} + +XS(XS_version_qv) +{ + dXSARGS; + (void)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 *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 = savesvpv(ver); + } + (void)scan_version(version,vs,TRUE); + Safefree(version); + + PUSHs(vs); + } + else + { + PUSHs(sv_2mortal(new_version(ver))); + } + + PUTBACK; + return; + } +} + XS(XS_utf8_is_utf8) { dXSARGS; + (void)cv; if (items != 1) Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)"); { - SV * sv = ST(0); + const SV *sv = ST(0); { if (SvUTF8(sv)) XSRETURN_YES; @@ -548,14 +653,15 @@ XS(XS_utf8_is_utf8) XS(XS_utf8_valid) { dXSARGS; + (void)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)) + const char *s = SvPV(sv,len); + if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len)) XSRETURN_YES; else XSRETURN_NO; @@ -567,6 +673,7 @@ XS(XS_utf8_valid) XS(XS_utf8_encode) { dXSARGS; + (void)cv; if (items != 1) Perl_croak(aTHX_ "Usage: utf8::encode(sv)"); { @@ -580,13 +687,12 @@ XS(XS_utf8_encode) XS(XS_utf8_decode) { dXSARGS; + (void)cv; if (items != 1) Perl_croak(aTHX_ "Usage: utf8::decode(sv)"); { SV * sv = ST(0); - bool RETVAL; - - RETVAL = sv_utf8_decode(sv); + const bool RETVAL = sv_utf8_decode(sv); ST(0) = boolSV(RETVAL); sv_2mortal(ST(0)); } @@ -596,6 +702,7 @@ XS(XS_utf8_decode) XS(XS_utf8_upgrade) { dXSARGS; + (void)cv; if (items != 1) Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)"); { @@ -612,20 +719,14 @@ XS(XS_utf8_upgrade) XS(XS_utf8_downgrade) { dXSARGS; + (void)cv; if (items < 1 || items > 2) Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)"); { SV * sv = ST(0); - bool failok; - bool RETVAL; + const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1)); + const bool RETVAL = sv_utf8_downgrade(sv, failok); - if (items < 2) - failok = 0; - else { - failok = (int)SvIV(ST(1)); - } - - RETVAL = sv_utf8_downgrade(sv, failok); ST(0) = boolSV(RETVAL); sv_2mortal(ST(0)); } @@ -635,7 +736,8 @@ XS(XS_utf8_downgrade) XS(XS_utf8_native_to_unicode) { dXSARGS; - UV uv = SvUV(ST(0)); + const UV uv = SvUV(ST(0)); + (void)cv; if (items > 1) Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)"); @@ -647,7 +749,8 @@ XS(XS_utf8_native_to_unicode) XS(XS_utf8_unicode_to_native) { dXSARGS; - UV uv = SvUV(ST(0)); + const UV uv = SvUV(ST(0)); + (void)cv; if (items > 1) Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)"); @@ -660,6 +763,8 @@ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ { dXSARGS; SV *sv = SvRV(ST(0)); + (void)cv; + if (items == 1) { if (SvREADONLY(sv)) XSRETURN_YES; @@ -684,6 +789,8 @@ XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ { dXSARGS; SV *sv = SvRV(ST(0)); + (void)cv; + if (items == 1) XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */ else if (items == 2) { @@ -694,64 +801,27 @@ 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)); + (void)cv; - /* 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; - } - + if (items != 1) + Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)"); + hv_clear_placeholders(hv); XSRETURN(0); } XS(XS_Regexp_DESTROY) { - + (void)cv; } XS(XS_PerlIO_get_layers) { dXSARGS; + (void)cv; if (items < 1 || items % 2 == 0) Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])"); #ifdef USE_PERLIO @@ -769,7 +839,7 @@ XS(XS_PerlIO_get_layers) SV **varp = svp; SV **valp = svp + 1; STRLEN klen; - char *key = SvPV(*varp, klen); + const char *key = SvPV(*varp, klen); switch (*key) { case 'i': @@ -808,7 +878,7 @@ XS(XS_PerlIO_get_layers) if (SvROK(sv) && isGV(SvRV(sv))) gv = (GV*)SvRV(sv); else - gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO); + gv = gv_fetchsv(sv, FALSE, SVt_PVIO); } if (gv && (io = GvIO(gv))) { @@ -874,3 +944,46 @@ XS(XS_PerlIO_get_layers) XSRETURN(0); } +XS(XS_Internals_hash_seed) +{ + /* Using dXSARGS would also have dITEM and dSP, + * which define 2 unused local variables. */ + dMARK; dAX; + (void)cv; + 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; + (void)cv; + XSRETURN_UV(PL_rehash_seed); +} + +XS(XS_Internals_HvREHASH) /* Subject to change */ +{ + dXSARGS; + (void)cv; + if (SvROK(ST(0))) { + const 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"); +} + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * vim: shiftwidth=4: +*/