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 <jpeacock@rowman.com>
Date: Wed, 21 Aug 2002 15:08:34 -0400 (20:08 BST)
Message-id: <3D63E532.7020305@rowman.com>

p4raw-id: //depot/perl@17747

4 files changed, 214 insertions, 2 deletions

diff --git a/sv.c b/sv.c
index 49f5c75f7f..c8d11dba10 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 1634cc340f..5cf97a8b9b 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 b92bd7a568..486b366f4a 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 5eea1c9fde..2fde6cbb85 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;
 }