uuid tests

apnadkarni · Mar 5, 2024 · 392e120 · 392e120
1 parent eb991c6
commit 392e120
Show file tree

Hide file tree

Showing 14 changed files with 245 additions and 43 deletions.
diff --git a/configure b/configure
@@ -5029,7 +5029,17 @@ else
     # Ensure no empty else clauses
     CLEANFILES="$CLEANFILES pkgIndex.tcl"
     #TEA_ADD_SOURCES([unix/unixFile.c])
-    #TEA_ADD_LIBS([-lsuperfly])
+
+    vars="-luuid"
+    for i in $vars; do
+	if test "${TEA_PLATFORM}" = "windows" -a "$GCC" = "yes" ; then
+	    # Convert foo.lib to -lfoo for GCC.  No-op if not *.lib
+	    i=`echo "$i" | sed -e 's/^\([^-].*\)\.[lL][iI][bB]$/-l\1/'`
+	fi
+	PKG_LIBS="$PKG_LIBS $i"
+    done
+
+
 fi
 
 #--------------------------------------------------------------------

diff --git a/configure.ac b/configure.ac
@@ -116,7 +116,7 @@ else
     # Ensure no empty else clauses
     CLEANFILES="$CLEANFILES pkgIndex.tcl"
     #TEA_ADD_SOURCES([unix/unixFile.c])
-    #TEA_ADD_LIBS([-lsuperfly])
+    TEA_ADD_LIBS([-luuid])
 fi
 
 #--------------------------------------------------------------------

diff --git a/generic/tclCffiTest.c b/generic/tclCffiTest.c
@@ -27,6 +27,15 @@
 #define CFFI_STDCALL
 #endif
 
+#ifdef _WIN32
+typedef UUID uuid_t;
+#else
+#include <uuid/uuid.h>
+typedef struct UUID {
+    uuid_t bytes;
+} UUID;
+#endif
+
 #define FNSTR2NUM(name_, fmt_, type_)           \
     EXTERN type_ name_ (char *s) {              \
         type_ val;                              \
@@ -1456,3 +1465,32 @@ void CFFI_STDCALL BaseInterfaceDeleteStdcall(struct BaseInterfaceStdcall *tiP)
 {
     free(tiP);
 }
+
+DLLEXPORT void copyUuid(const UUID *from, UUID *to)
+{
+    if (from)
+        *to = *from;
+    else
+        memset(to, 0, sizeof(*to));
+}
+
+DLLEXPORT void incrUuid(UUID *uuidP)
+{
+    unsigned char *p = (unsigned char *)uuidP;
+    p[0] += 1;
+    p[4] += 1;
+    p[6] += 1;
+    p[15] += 1;
+}
+
+DLLEXPORT void reverseUuidArray(int n, const UUID *from, UUID *to)
+{
+    if (from == NULL || n <= 0)
+        return;
+
+    int i;
+    for (i = 0; i < n; ++i) {
+        to[n-i-1] = from[i];
+    }
+}
+
diff --git a/generic/tclCffiTypes.c b/generic/tclCffiTypes.c
@@ -1708,6 +1708,42 @@ CffiIntValueToObj(const CffiTypeAndAttrs *typeAttrsP,
     return NULL;
 }
 
+/* Function: CffiUuidFromObj
+ * Unwraps a wrapped UUID based on type attributes
+ *
+ * ipCtxP - interpreter context
+ * typeAttrsP - type attributes. The base type is used without
+ *   considering the BYREF flag.
+ * valueObj - the *Tcl_Obj* containing the wrapped uuid
+ * uuidP - location to store UUID
+ *
+ * Returns:
+ * *TCL_OK* on success with the UUID store in *uuidP
+ * *TCL_ERROR* on error with message stored in the interpreter.
+ */
+static CffiResult
+CffiUuidFromObj(CffiInterpCtx *ipCtxP,
+                const CffiTypeAndAttrs *typeAttrsP,
+                Tcl_Obj *valueObj,
+                Tclh_UUID *uuidP)
+{
+    if (Tclh_UuidUnwrap(ipCtxP->interp, valueObj, uuidP) != TCL_OK) {
+        if ((typeAttrsP->flags & CFFI_F_ATTR_NULLIFEMPTY) == 0) {
+            return TCL_ERROR;
+        }
+        /* Don't use Tcl_Obj length functions to avoid shimmering */
+        Tcl_Size len;
+        (void)Tcl_GetStringFromObj(valueObj, &len);
+        if (len != 0)
+            return TCL_ERROR;
+
+        /* Empty string -> null uuid */
+        memset(uuidP, 0, sizeof(*uuidP));
+        Tcl_ResetResult(ipCtxP->interp); /* Clear error message */
+    }
+    return TCL_OK;
+}
+
 /* Function: CffiNativeScalarFromObj
  * Stores a native scalar value from Tcl_Obj wrapper
  *
@@ -1847,7 +1883,7 @@ CffiNativeScalarFromObj(CffiInterpCtx *ipCtxP,
             }
             break;
         case CFFI_K_TYPE_UUID:
-            CHECK(Tclh_UuidUnwrap(ip, valueObj, &value.u.uuid));
+            CHECK(CffiUuidFromObj(ipCtxP, typeAttrsP, valueObj, &value.u.uuid));
             *(indx + (Tclh_UUID *)valueBaseP) = value.u.uuid;
             break;
         case CFFI_K_TYPE_POINTER:

diff --git a/tclh b/tclh
diff --git a/tests/callback.test b/tests/callback.test
@@ -116,7 +116,7 @@ namespace eval ${NS}::test {
 
     # string, unistring, winstring
     set matrix [list string $testStrings(ascii) string.utf-8 $testStrings(unicode) string.jis0208 $testStrings(jis0208) unistring $testStrings(unicode)]
-    if {$::tcl_platform(platform) eq "windows"} {
+    if {[onwindows]} {
         lappend matrix winstring $testStrings(unicode)
     }
     foreach {type val} $matrix {
@@ -311,7 +311,7 @@ namespace eval ${NS}::test {
         cffi::prototype stdcall proto double {ch schar uch uchar shrt short ushrt ushort i int ui uint l long ul ulong ll longlong ull ulonglong f float d double}
         set caller manyargs_callback_stdcall
         set param_defs {ch schar uch uchar shrt short ushrt ushort i int ui uint l long ul ulong ll longlong ull ulonglong f float d double fnptr pointer.proto}
-        if {$::tcl_platform(platform) eq "windows" && $::tcl_platform(pointerSize) == 4} {
+        if {[onwindows] && [pointer32]} {
             # VC++ and mingw64 follow different naming conventions
             if {[catch {
                 testDll stdcall [list _${caller}@64 $caller] double $param_defs

diff --git a/tests/cffi.test b/tests/cffi.test
@@ -159,7 +159,7 @@ namespace eval ${NS}::test {
   f: float
   s: struct.::cffi::test::InnerTestStruct
   d: double}
-    if {$::tcl_platform(platform) eq "windows"} {
+    if {[onwindows]} {
         append desc \n {  wchars: {winchars[13]}}
     }
 

diff --git a/tests/common.tcl b/tests/common.tcl
@@ -28,6 +28,18 @@ if {[catch {package require $NS}]} {
 namespace eval cffi::test {
     namespace import ::tcltest::test ::tcltest::testConstraint
 
+    if {$::tcl_platform(platform) eq "windows"} {
+        proc onwindows {} {return 1}
+    } else {
+        proc onwindows {} {return 0}
+    }
+
+    if {$::tcl_platform(pointerSize) == 4} {
+        proc pointer32 {} {return 1}
+    } else {
+        proc pointer32 {} {return 0}
+    }
+
     testConstraint structbyval [cffi::pkgconfig get structbyval]
 
     variable testDllPath [file normalize [file join [file dirname $::cffi::dll_path] cffitest[info sharedlibextension]]]
@@ -40,8 +52,7 @@ namespace eval cffi::test {
     } else {
         tcltest::testConstraint libffi 1
     }
-    if {$::tcl_platform(platform) eq "windows" &&
-        $::tcl_platform(pointerSize) == 4} {
+    if {[onwindows] && [pointer32]} {
         tcltest::testConstraint win32 1
     } else {
         tcltest::testConstraint notwin32 1
@@ -59,7 +70,7 @@ namespace eval cffi::test {
     variable numericTypes [concat $intTypes $realTypes]
     variable stringTypes {string unistring binary}
     variable charArrayTypes {chars unichars bytes}
-    if {$::tcl_platform(platform) eq "windows"} {
+    if {[onwindows]} {
         lappend stringTypes winstring
         lappend charArrayTypes winchars
     }
@@ -143,7 +154,7 @@ namespace eval cffi::test {
     set testValues(binary) $testStrings(bytes)
     set testValues(struct.::StructValue) {c 42 i 4242}
     set testValues(union.::UnionValue) \x01\x02\x03\x04
-    if {$::tcl_platform(platform) eq "windows"} {
+    if {[onwindows]} {
         set testValues(winstring) $testStrings(unicode)
         set testValues(winchars\[[expr {[string length $testStrings(unicode)]+1}]\]) $testStrings(unicode)
     }
@@ -163,7 +174,7 @@ namespace eval cffi::test {
     variable stringAttrs {novaluechecks nullifempty}
     variable requirementAttrs {zero nonzero nonnegative positive}
     variable errorHandlerAttrs {errno}
-    if {$::tcl_platform(platform) eq "windows"} {
+    if {[onwindows]} {
         lappend errorAttrs winerror lasterror
         lappend errorHandlerAttrs winerror lasterror
     }
@@ -199,15 +210,15 @@ namespace eval cffi::test {
         jis string.jis0208
         uni unistring
     }
-    if {$::tcl_platform(platform) eq "windows"} {
+    if {[onwindows]} {
         lappend structDef win winstring
     }
     cffi::Struct create ::StructWithStrings $structDef
 
     proc makeStructWithStrings {} {
         variable testStrings
         set struct [list s $testStrings(ascii) utf8 $testStrings(unicode) jis $testStrings(jis0208) uni $testStrings(unicode)]
-        if {$::tcl_platform(platform) eq "windows"} {
+        if {[onwindows]} {
             lappend struct win $testStrings(unicode)
         }
         return $struct
@@ -233,7 +244,7 @@ namespace eval cffi::test {
         s struct.cffi::test::InnerTestStruct
         d double
     }
-    if {$::tcl_platform(platform) eq "windows"} {
+    if {[onwindows]} {
         lappend def wchars {winchars[13]}
     }
     cffi::Struct create ::TestStruct $def
@@ -261,7 +272,7 @@ namespace eval cffi::test {
                         f -0.25 \
                         s [list c INNER] \
                         d 0.125]
-        if {$::tcl_platform(platform) eq "windows"} {
+        if {[onwindows]} {
             lappend values wchars WCHARS
         }
         set mismatches {}