From 392e12061391f9e6b74a02aba933e8b704ce11ed Mon Sep 17 00:00:00 2001 From: "Ashok P. Nadkarni" Date: Tue, 5 Mar 2024 17:22:30 +0530 Subject: [PATCH] uuid tests --- configure | 12 ++++++- configure.ac | 2 +- generic/tclCffiTest.c | 38 ++++++++++++++++++++ generic/tclCffiTypes.c | 38 +++++++++++++++++++- tclh | 2 +- tests/callback.test | 4 +-- tests/cffi.test | 2 +- tests/common.tcl | 29 ++++++++++----- tests/function.test | 81 +++++++++++++++++++++++++++++++++++------- tests/interface.test | 2 +- tests/memory.test | 22 ++++++++++-- tests/prototype.test | 2 +- tests/struct.test | 50 ++++++++++++++++++++++---- tests/type.test | 4 +-- 14 files changed, 245 insertions(+), 43 deletions(-) diff --git a/configure b/configure index 273ccf5..d9c9e5b 100755 --- 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 index 9e1d0ba..d25094d 100644 --- 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 index 0eba928..7f3958f 100644 --- a/generic/tclCffiTest.c +++ b/generic/tclCffiTest.c @@ -27,6 +27,15 @@ #define CFFI_STDCALL #endif +#ifdef _WIN32 +typedef UUID uuid_t; +#else +#include +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 index c100780..04c3136 100644 --- 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 index 09477d3..4b63dd9 160000 --- a/tclh +++ b/tclh @@ -1 +1 @@ -Subproject commit 09477d31a8995af0e216dbced4a26987b8e8761b +Subproject commit 4b63dd94ab513865447526360ac2b4a887853258 diff --git a/tests/callback.test b/tests/callback.test index 8932701..1ec4555 100644 --- 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 index 0832453..498d917 100644 --- 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 index 9edc497..8c575c1 100644 --- 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,7 +210,7 @@ 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 @@ -207,7 +218,7 @@ namespace eval cffi::test { 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 {} diff --git a/tests/function.test b/tests/function.test index fca05e2..2d45fe2 100644 --- a/tests/function.test +++ b/tests/function.test @@ -105,7 +105,7 @@ namespace eval ${NS}::test { test stdcall-0 {stdcall} -body { - if {$::tcl_platform(platform) eq "windows" && $::tcl_platform(pointerSize) == 4} { + if {[onwindows] && [pointer32]} { # VC++ has _, mingw does not set fn _stdcalltest@16 if {[catch {testDll stdcall $fn double {a double b double}}]} { @@ -198,7 +198,7 @@ namespace eval ${NS}::test { rename $fn {} rename stdcall-alias {} } -body { - if {$::tcl_platform(platform) eq "windows" && $::tcl_platform(pointerSize) == 4} { + if {[onwindows] && [pointer32]} { set fn _stdcalltest@16 } else { set fn stdcalltest @@ -223,7 +223,7 @@ namespace eval ${NS}::test { test stdcalls-1 {Missing stdcall -ignoremissing} -cleanup { rename $fn {} } -body { - if {$::tcl_platform(platform) eq "windows" && $::tcl_platform(pointerSize) == 4} { + if {[onwindows] && [pointer32]} { set fn _stdcalltest@16 } else { set fn stdcalltest @@ -243,7 +243,7 @@ namespace eval ${NS}::test { test stdcalls-2 {Missing stdcall} -cleanup { rename $fn {} } -body { - if {$::tcl_platform(platform) eq "windows" && $::tcl_platform(pointerSize) == 4} { + if {[onwindows] && [pointer32]} { set fn _stdcalltest@16 } else { set fn stdcalltest @@ -262,7 +262,7 @@ namespace eval ${NS}::test { test stdcalls-3 {Comment in definitions} -cleanup { rename $fn {} } -body { - if {$::tcl_platform(platform) eq "windows" && $::tcl_platform(pointerSize) == 4} { + if {[onwindows] && [pointer32]} { set fn _stdcalltest@16 } else { set fn stdcalltest @@ -600,7 +600,7 @@ namespace eval ${NS}::test { ## Parameter tests - string, unistring, winstring set matrix [list string $testStrings(ascii) unistring $testStrings(unicode)] - if {$::tcl_platform(platform) eq "windows"} { + if {[onwindows]} { lappend matrix winstring $testStrings(unicode) } foreach {type val} $matrix { @@ -930,7 +930,7 @@ namespace eval ${NS}::test { ## Parameter tests - chars, unichars, winchars # NOTE: use only ascii for utf8 test here because of the buflen calculation set matrix [list chars $testStrings(ascii) chars.utf-8 abc unichars $testStrings(unicode)] - if {$::tcl_platform(platform) eq "windows"} { + if {[onwindows]} { lappend matrix winchars $testStrings(unicode) } foreach {type val} $matrix { @@ -1699,7 +1699,7 @@ namespace eval ${NS}::test { checkStructWithStringsByVal [makeStructWithStrings] } -constraints structbyval -result 0 - if {$::tcl_platform(platform) eq "windows"} { + if {[onwindows]} { set result [list c -127 i -2147483647 shrt -32767 uint 0 ushrt 0 l [expr {$intMin(long)+1}] uc 0 ul 0 chars CHARS ll -9223372036854775807 unic UNIC ull 0 b \x01\x02\x03 f 0.75 s {c INNER} d 1.125 wchars WCHARS] } else { set result [list c -127 i -2147483647 shrt -32767 uint 0 ushrt 0 l [expr {$intMin(long)+1}] uc 0 ul 0 chars CHARS ll -9223372036854775807 unic UNIC ull 0 b \x01\x02\x03 f 0.75 s {c INNER} d 1.125] @@ -1767,7 +1767,7 @@ namespace eval ${NS}::test { structCheck [list c 1 ll $ll] 1 $ll 2 } -result {Struct field "s" not found or inaccessible. Field missing in struct dictionary value. Error converting field ::S.s to a native value.} -returnCodes error - if {$::tcl_platform(platform) eq "windows"} { + if {[onwindows]} { set result [list c -127 i -2147483647 shrt -32767 uint 0 ushrt 0 l [expr {$intMin(long)+1}] uc 0 ul 0 chars CHARS ll -9223372036854775807 unic UNIC ull 0 b \x01\x02\x03 f 0.75 s {c INNER} d 1.125 wchars WCHARS] } else { set result [list c -127 i -2147483647 shrt -32767 uint 0 ushrt 0 l [expr {$intMin(long)+1}] uc 0 ul 0 chars CHARS ll -9223372036854775807 unic UNIC ull 0 b \x01\x02\x03 f 0.75 s {c INNER} d 1.125] @@ -1957,7 +1957,7 @@ namespace eval ${NS}::test { jis [list string.jis0208 [list default $testStrings(jis0208)]] \ uni [list unistring [list default $testStrings(unicode)]] \ ] - if {$::tcl_platform(platform) eq "windows"} { + if {[onwindows]} { lappend def win [list winstring [list default $testStrings(unicode)]] } cffi::Struct create X $def @@ -2701,7 +2701,7 @@ namespace eval ${NS}::test { # string, unistring return types set matrix {string string.utf-8 unistring} - if {$::tcl_platform(platform) eq "windows"} { + if {[onwindows]} { lappend matrix winstring } foreach type $matrix { @@ -2921,7 +2921,7 @@ namespace eval ${NS}::test { } set matrix {chars unichars bytes} - if {$::tcl_platform(platform) eq "windows"} { + if {[onwindows]} { lappend matrix winchars } foreach type $matrix { @@ -2998,7 +2998,7 @@ namespace eval ${NS}::test { ### # Array tests - empty arrays, all types set matrix [list {*}$numericTypes pointer struct.::TestStruct chars unichars bytes] - if {$::tcl_platform(platform) eq "windows"} { + if {[onwindows]} { lappend matrix winchars } foreach type $matrix { @@ -3767,6 +3767,61 @@ namespace eval ${NS}::test { list [::ns::int_to_int 65537] } -result 65537 + ### + # uuid type + test function-uuid-0 "uuid in,out" -body { + testDll function copyUuid void {from {uuid byref} to {uuid out}} + copyUuid $testValues(uuid) u + set u + } -result $testValues(uuid) + + test function-uuid-1 "uuid inout" -body { + testDll function incrUuid void {u {uuid inout}} + set u $testValues(uuid) + incrUuid u + set u + } -result [expr {[onwindows] ? "01020305-0507-0709-090a-0b0c0d0e0f01" : "02020304-0606-0808-090a-0b0c0d0e0f01"}] + + test function-uuid-2 "uuid - empty" -body { + testDll function copyUuid void {from {uuid byref} to {uuid out}} + copyUuid "" u + } -result {Invalid value "". Invalid UUID format.} -returnCodes error + + test function-uuid-3 "uuid - empty - nullifempty" -body { + testDll function copyUuid void {from {uuid byref nullifempty} to {uuid out}} + copyUuid "" u + set u + } -result {00000000-0000-0000-0000-000000000000} + + test function-uuid-4 "uuid in,out braced" -body { + testDll function copyUuid void {from {uuid byref} to {uuid out}} + copyUuid "{$testValues(uuid)}" u + set u + } -result $testValues(uuid) + + test function-uuid-5 "uuid array" -body { + testDll function reverseUuidArray void {count int from {uuid[count] in} to {uuid[count] out}} + reverseUuidArray 2 [list $testValues(uuid) 5d549ebb-f6e9-4995-af96-095f54fbf1dc] u + set u + } -result [list 5d549ebb-f6e9-4995-af96-095f54fbf1dc $testValues(uuid)] + + test function-uuid-6 "uuid default,retval" -body { + testDll function copyUuid void [list from [list uuid byref [list default $testValues(uuid)]] to {uuid retval}] + copyUuid + } -result $testValues(uuid) + + test function-uuid-error-0 "uuid in,out - error - short uuid" -body { + testDll function copyUuid void {from {uuid byref} to {uuid out}} + copyUuid [string range $testValues(uuid) 0 end-1] u + set u + } -result {Invalid value "01020304-0506-0708-090a-0b0c0d0e0f0". Invalid UUID format.} -returnCodes error + + test function-uuid-error-1 "uuid in,out - error - long uuid" -body { + testDll function copyUuid void {from {uuid byref} to {uuid out}} + copyUuid "$testValues(uuid)0" u + set u + } -result {Invalid value "01020304-0506-0708-090a-0b0c0d0e0f000". Invalid UUID format.} -returnCodes error + ### # saveerror test function-savederrors-errno-0 "savederror errno" -setup { diff --git a/tests/interface.test b/tests/interface.test index a51b004..7d6cc96 100644 --- a/tests/interface.test +++ b/tests/interface.test @@ -258,7 +258,7 @@ namespace eval ${::NS}::test { delete void {} } -disposemethod delete - if {$::tcl_platform(platform) eq "windows" && $::tcl_platform(pointerSize) == 4} { + if {[onwindows] && [pointer32]} { # VC++ has _, mingw does not set fn _BaseInterfaceNewStdcall@4 if {[catch { diff --git a/tests/memory.test b/tests/memory.test index 90d4776..1b1001d 100644 --- a/tests/memory.test +++ b/tests/memory.test @@ -736,7 +736,7 @@ namespace eval cffi::test { } -result $val set matrix {string unistring binary} - if {$::tcl_platform(platform) eq "windows"} { + if {[onwindows]} { lappend matrix winstring } foreach type $matrix { @@ -784,7 +784,7 @@ namespace eval cffi::test { cffi::memory get $p unistring } -result $testValues(unistring) - if {$::tcl_platform(platform) eq "windows"} { + if {[onwindows]} { test memory-get-winstring-0 "get winstring" -setup { unset -nocomplain s unset -nocomplain p @@ -942,6 +942,22 @@ namespace eval cffi::test { set p [cffi::memory new $type\[4\] [list 1 $val]] cffi::memory get $p $type\[4\] } -result [expr {$type in $realTypes? [list 1.0 $val 0.0 0.0] : [list 1 $val 0 0]}] + } elseif {$type eq "uuid"} { + test memory-new-$type-array-0 "new $type array" -cleanup { + if {[info exists p]} {cffi::memory free $p} + } -body { + unset -nocomplain p + set p [cffi::memory new $type\[2\] [list 5d549ebb-f6e9-4995-af96-095f54fbf1dc $val]] + cffi::memory get $p $type\[2\] + } -result [list 5d549ebb-f6e9-4995-af96-095f54fbf1dc $val] + test memory-new-$type-array-1 "new $type array fill extra elements with zeroes" -cleanup { + if {[info exists p]} {cffi::memory free $p} + } -body { + unset -nocomplain p + set p [cffi::memory new $type\[2\] [list $val]] + cffi::memory get $p $type\[2\] + } -result [list $val 00000000-0000-0000-0000-000000000000] + } if {[info exists badValues($type)]} { test memory-new-$type-badvalue-0 "new $type bad value" -body { @@ -1001,7 +1017,7 @@ namespace eval cffi::test { } -result [list {c 0 i 0} $val] set matrix {string unistring binary} - if {$::tcl_platform(platform) eq "windows"} { + if {[onwindows]} { lappend matrix winstring } diff --git a/tests/prototype.test b/tests/prototype.test index 8facb3b..c0f81db 100644 --- a/tests/prototype.test +++ b/tests/prototype.test @@ -13,7 +13,7 @@ namespace eval ${NS}::test { testnumargs prototype-stdcall "prototype stdcall" "NAME RETURNTYPE PARAMDEFS" "" proc getstdcalladdr {} { - if {$::tcl_platform(platform) eq "windows" && $::tcl_platform(pointerSize) == 4} { + if {[onwindows] && [pointer32]} { # VC++ has _, mingw does not set fn _stdcalltest@16 if {[catch {testDll addressof _stdcalltest@16} addr]} { diff --git a/tests/struct.test b/tests/struct.test index 7abb57f..6121e50 100644 --- a/tests/struct.test +++ b/tests/struct.test @@ -1008,7 +1008,7 @@ namespace eval cffi::test { longlong -5 ulonglong 5 float 0.5 double 1.5 chars[3] ab unichars[3] de } - if {$::tcl_platform(platform) eq "windows"} { + if {[onwindows]} { lappend matrix {winchars[3]} fg } @@ -1079,7 +1079,7 @@ namespace eval cffi::test { } -result [list fld [dict get [cffi::type info $type] Size]] } set matrix {float double pointer chars[2] unichars[2] string unistring binary struct.::TestStruct} - if {$::tcl_platform(platform) eq "windows"} { + if {[onwindows]} { lappend matrix winstring {winchars[2]} } foreach type $matrix { @@ -1561,7 +1561,7 @@ namespace eval cffi::test { set testvals { c 256 i notanint shrt 100000 uint -1 ushrt -1 l notanint uc -1 ul -1 chars toolongastring ll notanint unic toolongastring ull -1 b morethan3bytes f notanumber s {unknownfield 104} d notanumber } - if {$::tcl_platform(platform) eq "windows"} { + if {[onwindows]} { lappend testvals wchars toolongastring } foreach {fld val} $testvals { @@ -2084,17 +2084,17 @@ namespace eval cffi::test { ### # Extras, might already be tested elsewhere - test type-pointer-field-0 "pointer fields are always unsafe" -setup { + test struct-pointer-field-0 "pointer fields are always unsafe" -setup { cffi::Struct create S {p pointer} } -body { dict get [S info] Fields p Definition } -result {pointer unsafe} - test type-pointer-field-1 "pointer fields are always unsafe" -setup { + test struct-pointer-field-1 "pointer fields are always unsafe" -setup { cffi::Struct create S {p {pointer counted}} } -body { dict get [S info] Fields p Definition } -result {pointer unsafe} - test type-pointer-field-1 "pointer fields are always unsafe" -setup { + test struct-pointer-field-1 "pointer fields are always unsafe" -setup { cffi::Struct create S {p {pointer pinned}} } -body { dict get [S info] Fields p Definition @@ -2128,9 +2128,45 @@ namespace eval cffi::test { } -body { ::D fromnative $p } -result {Value * has the wrong type. Expected pointer to ::D.} -returnCodes error -match glob -} + ### + # struct guids + test struct-uuid-getnative-0 "struct uuid field" -setup { + cffi::Struct create S {c uchar u uuid} + } -cleanup { + S free $p + S destroy + } -body { + set p [S new [list c 42 u $testValues(uuid)]] + S getnative $p u + } -result $testValues(uuid) + + test struct-uuid-describe-0 "struct uuid describe" -setup { + cffi::Struct create S {c uchar u uuid} + } -cleanup { + S destroy + } -body { + S describe + } -result "Struct ::cffi::test::S nRefs=1 size=[expr {[onwindows] ? 20 : 17}] alignment=[expr {[onwindows] ? 4 : 1}] flags=0 nFields=2\n uchar c offset=0 size=1\n uuid u offset=[expr {[onwindows] ? 4 : 1}] size=16" + + test struct-uuid-info-0 "struct uuid info" -setup { + cffi::Struct create S {c uchar u uuid} + } -cleanup { + S destroy + } -body { + S info + } -result [expr {[onwindows] ? "Size 20 Alignment 4 Flags 0 Fields {c {Size 1 Offset 0 Definition uchar} u {Size 16 Offset 4 Definition uuid}}" : "Size 17 Alignment 1 Flags 0 Fields {c {Size 1 Offset 0 Definition uchar} u {Size 16 Offset 1 Definition uuid}}"}] + test struct-uuid-setnative-0 "struct uuid field" -setup { + cffi::Struct create S {c uchar u {uuid {default 5d549ebb-f6e9-4995-af96-095f54fbf1dc}}} + } -cleanup { + S free $p + S destroy + } -body { + set p [S new [list c 42]] + list [S getnative $p u] [S setnative $p u $testValues(uuid)] [S fromnative $p] + } -result {5d549ebb-f6e9-4995-af96-095f54fbf1dc {} {c 42 u 01020304-0506-0708-090a-0b0c0d0e0f00}} +} ::tcltest::cleanupTests namespace delete cffi::test diff --git a/tests/type.test b/tests/type.test index 8cd0d56..43baae0 100644 --- a/tests/type.test +++ b/tests/type.test @@ -939,7 +939,7 @@ namespace eval cffi::test { } set matrix {string string.utf-8 unistring} - if {$::tcl_platform(platform) eq "windows"} { + if {[onwindows]} { lappend matrix winstring } foreach type $matrix { @@ -1289,7 +1289,7 @@ namespace eval cffi::test { # uuid proc testuuid {typeattrs parse_mode expected_typeattrs {count 0}} { variable typeInfo - set alignment [expr {$::tcl_platform(platform) eq "windows" ? 4 : 1}] + set alignment [expr {$::tcl_platform(platform) eq "windows" ? 4 : 1}] if {"lasterror" in $typeattrs || "winerror" in $typeattrs} { set constraints win } else {