X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=universal.c;h=4822d3dd8c8cd8f0eaa1ac14269c95de5a731d13;hb=b4ad57f4f7fe2aca6dc52ea357ce9be7a7d38769;hp=83df6c5007ebfa45b53830a32232f94002ad8e3b;hpb=008fb0c0b128e68050936412d62bf4def14fc864;p=p5sagit%2Fp5-mst-13.2.git diff --git a/universal.c b/universal.c index 83df6c5..4822d3d 100644 --- a/universal.c +++ b/universal.c @@ -1,6 +1,6 @@ /* universal.c * - * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, + * 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 @@ -174,6 +174,7 @@ 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); @@ -217,6 +218,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); @@ -332,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 { @@ -355,13 +359,16 @@ 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 ) + if ( vcmp( req, sv ) > 0 ) Perl_croak(aTHX_ "%s version %"SVf" required--this is only version %"SVf, HvNAME(pkg), req, sv); @@ -379,15 +386,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; } @@ -409,9 +421,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; @@ -434,9 +444,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; @@ -480,7 +488,7 @@ XS(XS_version_vcmp) rs = newSViv(vcmp(lobj,rvs)); } - PUSHs(rs); + PUSHs(sv_2mortal(rs)); } PUTBACK; @@ -507,7 +515,7 @@ XS(XS_version_boolean) { SV *rs; rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) ); - PUSHs(rs); + PUSHs(sv_2mortal(rs)); } PUTBACK; @@ -566,6 +574,43 @@ XS(XS_version_is_alpha) } } +XS(XS_version_qv) +{ + dXSARGS; + 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 = savepv(SvPV_nolen(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; @@ -732,53 +777,13 @@ 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)); - - /* 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; - } - + if (items != 1) + Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)"); + hv_clear_placeholders(hv); XSRETURN(0); }