X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=universal.c;h=3e14a68bd7d4dffe0f8e90675a58aa5dfe21f4e5;hb=d91eeb70be5a52264f5ea6447fa60ac41c14b484;hp=6c555a1347d3d53fed32895f507d13c307f5c5c2;hpb=92d29cee5ff815b05b81b877528e4c77e73881c9;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/universal.c b/universal.c
index 6c555a1..3e14a68 100644
--- a/universal.c
+++ b/universal.c
@@ -74,7 +74,6 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level)
 		SV* sv = *svp++;
 		HV* basestash = gv_stashsv(sv, FALSE);
 		if (!basestash) {
-		    dTHR;
 		    if (ckWARN(WARN_MISC))
 			Perl_warner(aTHX_ WARN_SYNTAX,
 		             "Can't locate package %s for @%s::ISA",
@@ -131,9 +130,18 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
         : FALSE ;
 }
 
+#include "XSUB.h"
+
 void XS_UNIVERSAL_isa(pTHXo_ CV *cv);
 void XS_UNIVERSAL_can(pTHXo_ CV *cv);
 void XS_UNIVERSAL_VERSION(pTHXo_ CV *cv);
+XS(XS_utf8_valid);
+XS(XS_utf8_encode);
+XS(XS_utf8_decode);
+XS(XS_utf8_upgrade);
+XS(XS_utf8_downgrade);
+XS(XS_utf8_unicode_to_native);
+XS(XS_utf8_native_to_unicode);
 
 void
 Perl_boot_core_UNIVERSAL(pTHX)
@@ -143,9 +151,15 @@ 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);
+    newXS("utf8::valid", XS_utf8_valid, file);
+    newXS("utf8::encode", XS_utf8_encode, file);
+    newXS("utf8::decode", XS_utf8_decode, file);
+    newXS("utf8::upgrade", XS_utf8_upgrade, file);
+    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);
 }
 
-#include "XSUB.h"
 
 XS(XS_UNIVERSAL_isa)
 {
@@ -266,8 +280,8 @@ XS(XS_UNIVERSAL_VERSION)
 		    /* 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%vd required--"
-				   "this is only v%vd",
+			Perl_croak(aTHX_ "%s v%"VDf" required--"
+				   "this is only v%"VDf,
 				   HvNAME(pkg), req, sv);
 		    }
 		    goto finish;
@@ -300,3 +314,107 @@ finish:
     XSRETURN(1);
 }
 
+XS(XS_utf8_valid)
+{
+    dXSARGS;
+    if (items != 1)
+	Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
+    {
+	SV *	sv = ST(0);
+ {
+  STRLEN len;
+  char *s = SvPV(sv,len);
+  if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
+   XSRETURN_YES;
+  else
+   XSRETURN_NO;
+ }
+    }
+    XSRETURN_EMPTY;
+}
+
+XS(XS_utf8_encode)
+{
+    dXSARGS;
+    if (items != 1)
+	Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
+    {
+	SV *	sv = ST(0);
+
+	sv_utf8_encode(sv);
+    }
+    XSRETURN_EMPTY;
+}
+
+XS(XS_utf8_decode)
+{
+    dXSARGS;
+    if (items != 1)
+	Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
+    {
+	SV *	sv = ST(0);
+	bool	RETVAL;
+
+	RETVAL = sv_utf8_decode(sv);
+	ST(0) = boolSV(RETVAL);
+	sv_2mortal(ST(0));
+    }
+    XSRETURN(1);
+}
+
+XS(XS_utf8_upgrade)
+{
+    dXSARGS;
+    if (items != 1)
+	Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
+    {
+	SV *	sv = ST(0);
+	STRLEN	RETVAL;
+	dXSTARG;
+
+	RETVAL = sv_utf8_upgrade(sv);
+	XSprePUSH; PUSHi((IV)RETVAL);
+    }
+    XSRETURN(1);
+}
+
+XS(XS_utf8_downgrade)
+{
+    dXSARGS;
+    if (items < 1 || items > 2)
+	Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
+    {
+	SV *	sv = ST(0);
+	bool	failok;
+	bool	RETVAL;
+
+	if (items < 2)
+	    failok = 0;
+	else {
+	    failok = (int)SvIV(ST(1));
+	}
+
+	RETVAL = sv_utf8_downgrade(sv, failok);
+	ST(0) = boolSV(RETVAL);
+	sv_2mortal(ST(0));
+    }
+    XSRETURN(1);
+}
+
+XS(XS_utf8_native_to_unicode)
+{
+ dXSARGS;
+ UV uv = SvUV(ST(0));
+ ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
+ XSRETURN(1);
+}
+
+XS(XS_utf8_unicode_to_native)
+{
+ dXSARGS;
+ UV uv = SvUV(ST(0));
+ ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
+ XSRETURN(1);
+}
+
+