X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=universal.c;h=486b366f4aec947005874bf10144a2860b605e53;hb=b4bc5691c8dfad19b52d103e3b12af9342fcea38;hp=a9cb4ccbf950d7d8633f46450ade48fae55e6945;hpb=dfd4ef2f849f6c6c1ef68fdf03041001be25ade9;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/universal.c b/universal.c
index a9cb4cc..486b366 100644
--- a/universal.c
+++ b/universal.c
@@ -49,7 +49,7 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
 	&& (hv = GvHV(gv)))
     {
-	if (SvIV(subgen) == PL_sub_generation) {
+	if (SvIV(subgen) == (IV)PL_sub_generation) {
 	    SV* sv;
 	    SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
 	    if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
@@ -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);
@@ -169,7 +175,7 @@ XS(XS_utf8_unicode_to_native);
 XS(XS_utf8_native_to_unicode);
 XS(XS_Internals_SvREADONLY);
 XS(XS_Internals_SvREFCNT);
-XS(XS_Internals_hv_clear_placeholders);
+XS(XS_Internals_hv_clear_placehold);
 
 void
 Perl_boot_core_UNIVERSAL(pTHX)
@@ -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);
@@ -189,7 +216,7 @@ Perl_boot_core_UNIVERSAL(pTHX)
     newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
     newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
     newXSproto("Internals::hv_clear_placeholders",
-               XS_Internals_hv_clear_placeholders, file, "\\%");
+               XS_Internals_hv_clear_placehold, 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;
@@ -505,7 +703,7 @@ XS(XS_Internals_SvREFCNT)	/* This is dangerous stuff. */
 
 /* 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_placeholders)
+XS(XS_Internals_hv_clear_placehold)
 {
     dXSARGS;
     HV *hv = (HV *) SvRV(ST(0));
@@ -513,16 +711,23 @@ XS(XS_Internals_hv_clear_placeholders)
     /* I don't care how many parameters were passed in, but I want to avoid
        the unused variable warning. */
 
-    items = HvPLACEHOLDERS(hv);
+    items = (I32)HvPLACEHOLDERS(hv);
 
     if (items) {
         HE *entry;
         I32 riter = HvRITER(hv);
         HE *eiter = HvEITER(hv);
         hv_iterinit(hv);
-        while (items
-               && (entry
-                   = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
+        /* 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) {