From: John Peacock Date: Tue, 20 Aug 2002 22:51:46 +0000 (-0400) Subject: Re: [PATCH] Version object patch #1 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=439cb1c4bca8637a65af6ff559799d9f5b05b394;p=p5sagit%2Fp5-mst-13.2.git Re: [PATCH] Version object patch #1 Date: Tue, 20 Aug 2002 22:51:46 -0400 (Wed 03:51 BST) Message-id: <3D630042.6020407@rowman.com> Subject: Re: [REVISED PATCH] Magic v-strings From: John Peacock Date: Wed, 21 Aug 2002 15:08:34 -0400 (20:08 BST) Message-id: <3D63E532.7020305@rowman.com> p4raw-id: //depot/perl@17747 --- diff --git a/sv.c b/sv.c index 49f5c75..c8d11db 100644 --- a/sv.c +++ b/sv.c @@ -4027,6 +4027,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) MAGIC *mg = SvMAGIC(sstr); sv_magicext(dstr, NULL, PERL_MAGIC_vstring, NULL, mg->mg_ptr, mg->mg_len); + SvRMAGICAL_on(dstr); } } else if (sflags & SVp_IOK) { @@ -7238,6 +7239,8 @@ Perl_sv_reftype(pTHX_ SV *sv, int ob) case SVt_PVNV: case SVt_PVMG: case SVt_PVBM: + if (SvVOK(sv)) + return "VSTRING"; if (SvROK(sv)) return "REF"; else diff --git a/t/op/ver.t b/t/op/ver.t index 1634cc3..5cf97a8 100755 --- a/t/op/ver.t +++ b/t/op/ver.t @@ -11,7 +11,7 @@ $DOWARN = 1; # enable run-time warnings now use Config; require "test.pl"; -plan( tests => 47 ); +plan( tests => 50 ); eval { use v5.5.640; }; is( $@, '', "use v5.5.640; $@"); @@ -245,3 +245,12 @@ SKIP: { } } } + +# Tests for magic v-strings + +$v = 1.2.3; +is( ref(\$v), 'VSTRING', 'v-string objects' ); + +$v = v1.2_3; +is( ref(\$v), 'VSTRING', 'v-string objects with v' ); +is( sprintf("%vd", $v), '1.23', 'v-string ignores underscores' ); diff --git a/universal.c b/universal.c index b92bd7a..486b366 100644 --- a/universal.c +++ b/universal.c @@ -160,6 +160,12 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *name) void XS_UNIVERSAL_isa(pTHX_ CV *cv); void XS_UNIVERSAL_can(pTHX_ CV *cv); void XS_UNIVERSAL_VERSION(pTHX_ CV *cv); +XS(XS_version_new); +XS(XS_version_stringify); +XS(XS_version_numify); +XS(XS_version_vcmp); +XS(XS_version_boolean); +XS(XS_version_noop); XS(XS_utf8_valid); XS(XS_utf8_encode); XS(XS_utf8_decode); @@ -179,6 +185,27 @@ Perl_boot_core_UNIVERSAL(pTHX) newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file); + { + /* create the package stash for version objects */ + HV *hv = get_hv("version::OVERLOAD",TRUE); + SV *sv = *hv_fetch(hv,"register",8,1); + sv_inc(sv); + SvSETMAGIC(sv); + /* Make it findable via fetchmethod */ + newXS("version::()", NULL, file); + newXS("version::new", XS_version_new, file); + newXS("version::(\"\"", XS_version_stringify, file); + newXS("version::stringify", XS_version_stringify, file); + newXS("version::(0+", XS_version_numify, file); + newXS("version::numify", XS_version_numify, file); + newXS("version::(cmp", XS_version_vcmp, file); + newXS("version::(<=>", XS_version_vcmp, file); + newXS("version::vcmp", XS_version_vcmp, file); + newXS("version::(bool", XS_version_boolean, file); + newXS("version::boolean", XS_version_boolean, file); + newXS("version::(nomethod", XS_version_noop, file); + newXS("version::noop", XS_version_noop, file); + } newXS("utf8::valid", XS_utf8_valid, file); newXS("utf8::encode", XS_utf8_encode, file); newXS("utf8::decode", XS_utf8_decode, file); @@ -354,6 +381,177 @@ finish: XSRETURN(1); } +XS(XS_version_new) +{ + dXSARGS; + if (items != 2) + Perl_croak(aTHX_ "Usage: version::new(class, version)"); + SP -= items; + { +/* char * class = (char *)SvPV_nolen(ST(0)); */ + SV * version = ST(1); + +{ + PUSHs(new_version(version)); +} + + PUTBACK; + return; + } +} + +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 + croak("lobj is not of type version"); + +{ + SV *vs = NEWSV(92,5); + if ( lobj == SvRV(PL_patchlevel) ) + sv_catsv(vs,lobj); + else + vstringify(vs,lobj); + PUSHs(vs); +} + + PUTBACK; + return; + } +} + +XS(XS_version_numify) +{ + 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 + croak("lobj is not of type version"); + +{ + SV *vs = NEWSV(92,5); + vnumify(vs,lobj); + PUSHs(vs); +} + + PUTBACK; + return; + } +} + +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 + croak("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(sv_cmp(rvs,lobj)); + } + else + { + rs = newSViv(sv_cmp(lobj,rvs)); + } + + PUSHs(rs); +} + + PUTBACK; + return; + } +} + +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 + croak("lobj is not of type version"); + +{ + SV *rs; + rs = newSViv(sv_cmp(lobj,Nullsv)); + PUSHs(rs); +} + + 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 + croak("lobj is not of type version"); + +{ + croak("operation not supported with version object"); +} + + } + XSRETURN_EMPTY; +} + XS(XS_utf8_valid) { dXSARGS; diff --git a/util.c b/util.c index 5eea1c9..2fde6cb 100644 --- a/util.c +++ b/util.c @@ -4072,6 +4072,7 @@ char * Perl_scan_vstring(pTHX_ char *s, SV *sv) { char *pos = s; + char *start = s; if (*pos == 'v') pos++; /* get past 'v' */ while (isDIGIT(*pos) || *pos == '_') pos++; @@ -4121,7 +4122,8 @@ Perl_scan_vstring(pTHX_ char *s, SV *sv) pos++; } SvPOK_on(sv); - SvREADONLY_on(sv); + sv_magicext(sv,NULL,PERL_MAGIC_vstring,NULL,(const char*)start, pos-start); + SvRMAGICAL_on(sv); } return s; }