Add support for tcl::prefix as an optional extension

Also adds Jim_ListGetIndex(), like Jim_ListIndex() but with a more convenient interface

5 files changed, 195 insertions, 30 deletions

diff --git a/Makefile.in b/Makefile.in
index 660bd9d..37b01db 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -153,6 +153,10 @@ pack.so: jim-pack.c
 	$(CC) $(CFLAGS) $(SHOBJ_CFLAGS) -c -o jim-pack.o $> $^
 	$(CC) $(CFLAGS) $(LDFLAGS) $(SHOBJ_LDFLAGS) -o $@ jim-pack.o $(SH_LIBJIM) @LDLIBS_pack@
 
+tclprefix.so: jim-tclprefix.c
+	$(CC) $(CFLAGS) $(SHOBJ_CFLAGS) -c -o jim-tclprefix.o $> $^
+	$(CC) $(CFLAGS) $(LDFLAGS) $(SHOBJ_LDFLAGS) -o $@ jim-tclprefix.o $(SH_LIBJIM) @LDLIBS_tclprefix@
+
 sqlite.so: jim-sqlite.c
 	$(CC) $(CFLAGS) $(SHOBJ_CFLAGS) -c -o jim-sqlite.o $> $^
 	$(CC) $(CFLAGS) $(LDFLAGS) $(SHOBJ_LDFLAGS) -o $@ jim-sqlite.o $(SH_LIBJIM) @LDLIBS_sqlite@
diff --git a/auto.def b/auto.def
index a1150fe..6c241d7 100644
--- a/auto.def
+++ b/auto.def
@@ -44,6 +44,7 @@ options {
         readline  - Interface to libreadline
         rlprompt  - Tcl wrapper around the readline extension
         mk        - Interface to Metakit
+        tclprefix - Support for the tcl::prefix command
         sqlite    - Interface to sqlite
         sqlite3   - Interface to sqlite3
         win32     - Interface to win32
@@ -210,6 +211,7 @@ dict set extdb attrs {
     stdlib    { tcl static }
     syslog    { optional }
     tclcompat { tcl static }
+    tclprefix { optional full }
     tree      { tcl optional full }
     win32     { optional }
 }
diff --git a/jim.c b/jim.c
index 6ab1e9d..6ed5c4c 100644
--- a/jim.c
+++ b/jim.c
@@ -302,11 +302,6 @@ static int JimGlobMatch(const char *pattern, const char *string, int nocase)
     return 0;
 }
 
-static int JimStringMatch(Jim_Interp *interp, Jim_Obj *patternObj, const char *string, int nocase)
-{
-    return JimGlobMatch(Jim_String(patternObj), string, nocase);
-}
-
 /**
  * string comparison works on binary data.
  *
@@ -326,17 +321,17 @@ static int JimStringCompare(const char *s1, int l1, const char *s2, int l2)
 }
 
 /**
- * No-case version.
+ * Compare null terminated strings, up to a maximum of 'maxchars' characters,
+ * (or end of string if 'maxchars' is -1).
  *
- * If maxchars is -1, compares to end of string.
- * Otherwise compares at most 'maxchars' characters.
+ * Returns -1, 0, 1 for s1 < s2, s1 == s2, s1 > s2 respectively.
  */
-static int JimStringCompareNoCase(const char *s1, const char *s2, int maxchars)
+static int JimStringCompareLen(const char *s1, const char *s2, int maxchars, int nocase)
 {
     while (*s1 && *s2 && maxchars) {
         int c1, c2;
-        s1 += utf8_tounicode_case(s1, &c1, 1);
-        s2 += utf8_tounicode_case(s2, &c2, 1);
+        s1 += utf8_tounicode_case(s1, &c1, nocase);
+        s2 += utf8_tounicode_case(s2, &c2, nocase);
         if (c1 != c2) {
             return JimSign(c1 - c2);
         }
@@ -2434,23 +2429,33 @@ int Jim_StringEqObj(Jim_Obj *aObjPtr, Jim_Obj *bObjPtr)
 
 int Jim_StringMatchObj(Jim_Interp *interp, Jim_Obj *patternObjPtr, Jim_Obj *objPtr, int nocase)
 {
-    return JimStringMatch(interp, patternObjPtr, Jim_String(objPtr), nocase);
+    return JimGlobMatch(Jim_String(patternObjPtr), Jim_String(objPtr), nocase);
 }
 
 int Jim_StringCompareObj(Jim_Interp *interp, Jim_Obj *firstObjPtr, Jim_Obj *secondObjPtr, int nocase)
 {
-    const char *s1, *s2;
     int l1, l2;
-
-    s1 = Jim_GetString(firstObjPtr, &l1);
-    s2 = Jim_GetString(secondObjPtr, &l2);
+    const char *s1 = Jim_GetString(firstObjPtr, &l1);
+    const char *s2 = Jim_GetString(secondObjPtr, &l2);
 
     if (nocase) {
-        return JimStringCompareNoCase(s1, s2, -1);
+        /* Do a character compare for nocase */
+        return JimStringCompareLen(s1, s2, -1, nocase);
     }
     return JimStringCompare(s1, l1, s2, l2);
 }
 
+/**
+ * Like Jim_StringCompareObj() except compares to a maximum of the length of firstObjPtr.
+ */
+int Jim_StringCompareLenObj(Jim_Interp *interp, Jim_Obj *firstObjPtr, Jim_Obj *secondObjPtr, int nocase)
+{
+    const char *s1 = Jim_String(firstObjPtr);
+    const char *s2 = Jim_String(secondObjPtr);
+
+    return JimStringCompareLen(s1, s2, Jim_Utf8Length(interp, firstObjPtr), nocase);
+}
+
 /* Convert a range, as returned by Jim_GetRange(), into
  * an absolute index into an object of the specified length.
  * This function may return negative values, or values
@@ -6241,20 +6246,27 @@ void Jim_ListInsertElements(Jim_Interp *interp, Jim_Obj *listPtr, int idx,
     ListInsertElements(listPtr, idx, objc, objVec);
 }
 
-int Jim_ListIndex(Jim_Interp *interp, Jim_Obj *listPtr, int idx, Jim_Obj **objPtrPtr, int flags)
+Jim_Obj *Jim_ListGetIndex(Jim_Interp *interp, Jim_Obj *listPtr, int idx)
 {
     SetListFromAny(interp, listPtr);
     if ((idx >= 0 && idx >= listPtr->internalRep.listValue.len) ||
         (idx < 0 && (-idx - 1) >= listPtr->internalRep.listValue.len)) {
+        return NULL;
+    }
+    if (idx < 0)
+        idx = listPtr->internalRep.listValue.len + idx;
+    return listPtr->internalRep.listValue.ele[idx];
+}
+
+int Jim_ListIndex(Jim_Interp *interp, Jim_Obj *listPtr, int idx, Jim_Obj **objPtrPtr, int flags)
+{
+    *objPtrPtr = Jim_ListGetIndex(interp, listPtr, idx);
+    if (*objPtrPtr == NULL) {
         if (flags & JIM_ERRMSG) {
             Jim_SetResultString(interp, "list index out of range", -1);
         }
-        *objPtrPtr = NULL;
         return JIM_ERR;
     }
-    if (idx < 0)
-        idx = listPtr->internalRep.listValue.len + idx;
-    *objPtrPtr = listPtr->internalRep.listValue.ele[idx];
     return JIM_OK;
 }
 
@@ -10771,7 +10783,7 @@ static Jim_Obj *JimHashtablePatternMatch(Jim_Interp *interp, Jim_HashTable *ht,
     else {
         Jim_HashTableIterator *htiter = Jim_GetHashTableIterator(ht);
         while ((he = Jim_NextHashEntry(htiter)) != NULL) {
-            if (patternObjPtr == NULL || JimStringMatch(interp, patternObjPtr, he->key, 0)) {
+            if (patternObjPtr == NULL || JimGlobMatch(Jim_String(patternObjPtr), he->key, 0)) {
                 callback(interp, listObjPtr, he, type);
             }
         }
@@ -11890,7 +11902,7 @@ static int Jim_LsearchCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *
         Jim_ListIndex(interp, argv[0], i, &objPtr, JIM_NONE);
         switch (opt_match) {
             case OPT_EXACT:
-                eq = Jim_StringCompareObj(interp, objPtr, argv[1], opt_nocase) == 0;
+                eq = Jim_StringCompareObj(interp, argv[1], objPtr, opt_nocase) == 0;
                 break;
 
             case OPT_GLOB:
@@ -12834,12 +12846,7 @@ static Jim_Obj *JimStringMap(Jim_Interp *interp, Jim_Obj *mapListObjPtr,
 
             if (strLen >= kl && kl) {
                 int rc;
-                if (nocase) {
-                    rc = JimStringCompareNoCase(str, k, kl);
-                }
-                else {
-                    rc = JimStringCompare(str, kl, k, kl);
-                }
+                rc = JimStringCompareLen(str, k, kl, nocase);
                 if (rc == 0) {
                     if (noMatchStart) {
                         Jim_AppendString(interp, resultObjPtr, noMatchStart, str - noMatchStart);
diff --git a/jim.h b/jim.h
index 3e9e983..206463e 100644
--- a/jim.h
+++ b/jim.h
@@ -719,6 +719,8 @@ JIM_EXPORT int Jim_CompareStringImmediate (Jim_Interp *interp,
         Jim_Obj *objPtr, const char *str);
 JIM_EXPORT int Jim_StringCompareObj(Jim_Interp *interp, Jim_Obj *firstObjPtr,
         Jim_Obj *secondObjPtr, int nocase);
+JIM_EXPORT int Jim_StringCompareLenObj(Jim_Interp *interp, Jim_Obj *firstObjPtr,
+        Jim_Obj *secondObjPtr, int nocase);
 JIM_EXPORT int Jim_Utf8Length(Jim_Interp *interp, Jim_Obj *objPtr);
 
 /* reference object */
@@ -793,6 +795,7 @@ JIM_EXPORT void Jim_ListAppendList (Jim_Interp *interp,
 JIM_EXPORT int Jim_ListLength (Jim_Interp *interp, Jim_Obj *objPtr);
 JIM_EXPORT int Jim_ListIndex (Jim_Interp *interp, Jim_Obj *listPrt,
         int listindex, Jim_Obj **objPtrPtr, int seterr);
+JIM_EXPORT Jim_Obj *Jim_ListGetIndex(Jim_Interp *interp, Jim_Obj *listPtr, int idx);
 JIM_EXPORT int Jim_SetListIndex (Jim_Interp *interp,
         Jim_Obj *varNamePtr, Jim_Obj *const *indexv, int indexc,
         Jim_Obj *newObjPtr);
diff --git a/tests/prefix.test b/tests/prefix.test
new file mode 100644
index 0000000..e4b8cc3
--- /dev/null
+++ b/tests/prefix.test
@@ -0,0 +1,149 @@
+# Commands covered:  tcl::prefix
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands.  Sourcing this file into Tcl runs the tests and
+# generates output for errors.  No output means no errors were found.
+#
+# Copyright (c) 1991-1993 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+source [file dirname [info script]]/testing.tcl
+
+needs cmd tcl::prefix prefix
+
+test string-26.1 {tcl::prefix, too few args} -body {
+    tcl::prefix match a
+} -returnCodes 1 -match glob -result {wrong # args: should be "tcl::prefix match ?options*? table string"}
+test string-26.2 {tcl::prefix, bad args} -body {
+    tcl::prefix match a b c
+} -returnCodes 1 -result {bad option "a": must be -error, -exact, or -message}
+test string-26.2.1 {tcl::prefix, empty table} -body {
+    tcl::prefix match {} foo
+} -returnCodes 1 -result {bad option "foo": no valid options}
+
+
+
+test string-26.3.1 {tcl::prefix, bad args} -body {
+    tcl::prefix match -error "x" -exact str1 str2
+} -returnCodes 1 -match glob -result *
+test string-26.3.2 {tcl::prefix, bad args} -body {
+    tcl::prefix match -error str1 str2
+} -returnCodes 1 -result {missing error options}
+test string-26.4 {tcl::prefix, bad args} -body {
+    tcl::prefix match -message str1 str2
+} -returnCodes 1 -result {missing message}
+test string-26.5 {tcl::prefix} {
+    tcl::prefix match {apa bepa cepa depa} cepa
+} cepa
+test string-26.6 {tcl::prefix} {
+    tcl::prefix match {apa bepa cepa depa} be
+} bepa
+test string-26.7 {tcl::prefix} -body {
+    tcl::prefix match -exact {apa bepa cepa depa} be
+} -returnCodes 1 -result {bad option "be": must be apa, bepa, cepa, or depa}
+test string-26.8 {tcl::prefix} -body {
+    tcl::prefix match -message switch {apa bear bepa depa} be
+} -returnCodes 1 -result {ambiguous switch "be": must be apa, bear, bepa, or depa}
+test string-26.9 {tcl::prefix} -body {
+    tcl::prefix match -error {} {apa bepa bear depa} be
+} -returnCodes 0 -result {}
+test string-26.10 {tcl::prefix} -body {
+    tcl::prefix match -error {-level 1} {apa bear bepa depa} be
+} -returnCodes 2 -result {ambiguous option "be": must be apa, bear, bepa, or depa}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+test string-27.1 {tcl::prefix all, too few args} -body {
+    tcl::prefix all a
+} -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"}
+test string-27.2 {tcl::prefix all, bad args} -body {
+    tcl::prefix all a b c
+} -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"}
+
+
+
+test string-27.4 {tcl::prefix all} {
+    tcl::prefix all {apa bepa cepa depa} c
+} cepa
+test string-27.5 {tcl::prefix all} {
+    tcl::prefix all {apa bepa cepa depa} cepa
+} cepa
+test string-27.6 {tcl::prefix all} {
+    tcl::prefix all {apa bepa cepa depa} cepax
+} {}
+test string-27.7 {tcl::prefix all} {
+    tcl::prefix all {apa aska appa} a
+} {apa aska appa}
+test string-27.8 {tcl::prefix all} {
+    tcl::prefix all {apa aska appa} ap
+} {apa appa}
+test string-27.9 {tcl::prefix all} {
+    tcl::prefix all {apa aska appa} p
+} {}
+test string-27.10 {tcl::prefix all} {
+    tcl::prefix all {apa aska appa} {}
+} {apa aska appa}
+
+test string-28.1 {tcl::prefix longest, too few args} -body {
+    tcl::prefix longest a
+} -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"}
+test string-28.2 {tcl::prefix longest, bad args} -body {
+    tcl::prefix longest a b c
+} -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"}
+
+
+
+test string-28.4 {tcl::prefix longest} {
+    tcl::prefix longest {apa bepa cepa depa} c
+} cepa
+test string-28.5 {tcl::prefix longest} {
+    tcl::prefix longest {apa bepa cepa depa} cepa
+} cepa
+test string-28.6 {tcl::prefix longest} {
+    tcl::prefix longest {apa bepa cepa depa} cepax
+} {}
+test string-28.7 {tcl::prefix longest} {
+    tcl::prefix longest {apa aska appa} a
+} a
+test string-28.8 {tcl::prefix longest} {
+    tcl::prefix longest {apa aska appa} ap
+} ap
+test string-28.9 {tcl::prefix longest} {
+    tcl::prefix longest {apa bska appa} a
+} ap
+test string-28.10 {tcl::prefix longest} {
+    tcl::prefix longest {apa bska appa} {}
+} {}
+test string-28.11 {tcl::prefix longest} {
+    tcl::prefix longest {{} bska appa} {}
+} {}
+test string-28.12 {tcl::prefix longest} {
+    tcl::prefix longest {apa {} appa} {}
+} {}
+test string-28.13 {tcl::prefix longest} {
+    # Test UTF8 handling
+    tcl::prefix longest {ax\x90 bep ax\x91} a
+} ax
+
+testreport