X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=universal.c;h=533d84399fde3a1226e03c293833573b12948334;hb=ee6cee0c2c00e175d3cfaf8f48ea1776d3629878;hp=53b9e9fb702e84e911de2eb7c7ac34319490be5e;hpb=301daebccb7cf8ef4420fe0ae3cdddd299f11568;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/universal.c b/universal.c
index 53b9e9f..533d843 100644
--- a/universal.c
+++ b/universal.c
@@ -1,3 +1,18 @@
+/*    universal.c
+ *
+ *    Copyright (c) 1997-2002, Larry Wall
+ *
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * "The roots of those mountains must be roots indeed; there must be
+ * great secrets buried there which have not been discovered since the
+ * beginning." --Gandalf, relating Gollum's story
+ */
+
 #include "EXTERN.h"
 #define PERL_IN_UNIVERSAL_C
 #include "perl.h"
@@ -34,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) {
@@ -78,7 +93,7 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
 		HV* basestash = gv_stashsv(sv, FALSE);
 		if (!basestash) {
 		    if (ckWARN(WARN_MISC))
-			Perl_warner(aTHX_ WARN_SYNTAX,
+			Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 		             "Can't locate package %s for @%s::ISA",
 			    SvPVX(sv), HvNAME(stash));
 		    continue;
@@ -145,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);
@@ -152,7 +173,9 @@ XS(XS_utf8_upgrade);
 XS(XS_utf8_downgrade);
 XS(XS_utf8_unicode_to_native);
 XS(XS_utf8_native_to_unicode);
-XS(XS_access_readonly);
+XS(XS_Internals_SvREADONLY);
+XS(XS_Internals_SvREFCNT);
+XS(XS_Internals_hv_clear_placehold);
 
 void
 Perl_boot_core_UNIVERSAL(pTHX)
@@ -162,6 +185,24 @@ 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);
+    {
+	/* register the overloading (type 'A') magic */
+	PL_amagic_generation++;
+	/* Make it findable via fetchmethod */
+	newXS("version::()", XS_version_noop, 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);
@@ -169,7 +210,10 @@ Perl_boot_core_UNIVERSAL(pTHX)
     newXS("utf8::downgrade", XS_utf8_downgrade, file);
     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
-    newXSproto("access::readonly",XS_access_readonly, file, "\\[$%@];$");
+    newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
+    newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
+    newXSproto("Internals::hv_clear_placeholders",
+               XS_Internals_hv_clear_placehold, file, "\\%");
 }
 
 
@@ -275,57 +319,198 @@ XS(XS_UNIVERSAL_VERSION)
 	STRLEN len;
 	SV *req = ST(1);
 
-	if (undef)
-	    Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed",
-		       HvNAME(pkg), HvNAME(pkg));
-
-	if (!SvNIOK(sv) && SvPOK(sv)) {
-	    char *str = SvPVx(sv,len);
-	    while (len) {
-		--len;
-		/* XXX could DWIM "1.2.3" here */
-		if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
-		    break;
-	    }
-	    if (len) {
-		if (SvNOK(req) && SvPOK(req)) {
-		    /* they said C<use Foo v1.2.3> and $Foo::VERSION
-		     * doesn't look like a float: do string compare */
-		    if (sv_cmp(req,sv) == 1) {
-			Perl_croak(aTHX_ "%s v%"VDf" required--"
-				   "this is only v%"VDf,
-				   HvNAME(pkg), req, sv);
-		    }
-		    goto finish;
-		}
-		/* they said C<use Foo 1.002_003> and $Foo::VERSION
-		 * doesn't look like a float: force numeric compare */
-		(void)SvUPGRADE(sv, SVt_PVNV);
-		SvNVX(sv) = str_to_version(sv);
-		SvPOK_off(sv);
-		SvNOK_on(sv);
-	    }
-	}
-	/* if we get here, we're looking for a numeric comparison,
-	 * so force the required version into a float, even if they
-	 * said C<use Foo v1.2.3> */
-	if (SvNOK(req) && SvPOK(req)) {
-	    NV n = SvNV(req);
-	    req = sv_newmortal();
-	    sv_setnv(req, n);
+	if (undef) {
+	     if (pkg)
+		  Perl_croak(aTHX_
+			     "%s does not define $%s::VERSION--version check failed",
+			     HvNAME(pkg), HvNAME(pkg));
+	     else {
+		  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 (SvNV(req) > SvNV(sv))
+	if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
 	    Perl_croak(aTHX_ "%s version %s required--this is only version %s",
-		       HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
+		HvNAME(pkg), SvPV(req,PL_na), SvPV(sv,PL_na));
     }
 
-finish:
     ST(0) = sv;
 
     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
+                Perl_croak(aTHX_ "lobj is not of type version");
+
+{
+    PUSHs(vstringify(lobj));
+}
+
+	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
+                Perl_croak(aTHX_ "lobj is not of type version");
+
+{
+    PUSHs(vnumify(lobj));
+}
+
+	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
+                Perl_croak(aTHX_ "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(vcmp(rvs,lobj));
+    }
+    else
+    {
+        rs = newSViv(vcmp(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
+                Perl_croak(aTHX_ "lobj is not of type version");
+
+{
+    SV	*rs;
+    rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
+    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
+                Perl_croak(aTHX_ "lobj is not of type version");
+
+{
+    Perl_croak(aTHX_ "operation not supported with version object");
+}
+
+    }
+    XSRETURN_EMPTY;
+}
+
 XS(XS_utf8_valid)
 {
     dXSARGS;
@@ -437,22 +622,90 @@ XS(XS_utf8_unicode_to_native)
  XSRETURN(1);
 }
 
-XS(XS_access_readonly)
+XS(XS_Internals_SvREADONLY)	/* This is dangerous stuff. */
 {
     dXSARGS;
     SV *sv = SvRV(ST(0));
-    IV old = SvREADONLY(sv);
-    if (items == 2) {
+    if (items == 1) {
+	 if (SvREADONLY(sv))
+	     XSRETURN_YES;
+	 else
+	     XSRETURN_NO;
+    }
+    else if (items == 2) {
 	if (SvTRUE(ST(1))) {
 	    SvREADONLY_on(sv);
+	    XSRETURN_YES;
 	}
 	else {
+	    /* I hope you really know what you are doing. */
 	    SvREADONLY_off(sv);
+	    XSRETURN_NO;
 	}
     }
-    if (old)
-	XSRETURN_YES;
-    else
-	XSRETURN_NO;
+    XSRETURN_UNDEF; /* Can't happen. */
+}
+
+XS(XS_Internals_SvREFCNT)	/* This is dangerous stuff. */
+{
+    dXSARGS;
+    SV *sv = SvRV(ST(0));
+    if (items == 1)
+	 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
+    else if (items == 2) {
+         /* I hope you really know what you are doing. */
+	 SvREFCNT(sv) = SvIV(ST(1));
+	 XSRETURN_IV(SvREFCNT(sv));
+    }
+    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_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;
+    }
+
+    XSRETURN(0);
+}