lsort: add support for -dict

Signed-off-by: Steve Bennett <steveb@workware.net.au>

2 files changed, 177 insertions, 4 deletions

diff --git a/jim.c b/jim.c
index fba53ac..c1d3752 100644
--- a/jim.c
+++ b/jim.c
@@ -6904,7 +6904,8 @@ struct lsort_info {
         JIM_LSORT_NOCASE,
         JIM_LSORT_INTEGER,
         JIM_LSORT_REAL,
-        JIM_LSORT_COMMAND
+        JIM_LSORT_COMMAND,
+        JIM_LSORT_DICT
     } type;
     int order;
     Jim_Obj **indexv;
@@ -6937,6 +6938,45 @@ static int ListSortStringNoCase(Jim_Obj **lhsObj, Jim_Obj **rhsObj)
     return Jim_StringCompareObj(sort_info->interp, *lhsObj, *rhsObj, 1) * sort_info->order;
 }
 
+static int ListSortDict(Jim_Obj **lhsObj, Jim_Obj **rhsObj)
+{
+    /* XXX Does not compare past embedded nulls */
+    const char *left = Jim_String(*lhsObj);
+    const char *right = Jim_String(*rhsObj);
+
+    while (1) {
+        if (isdigit(UCHAR(*left)) && isdigit(UCHAR(*right))) {
+            /* extract and compare integers */
+            jim_wide lint, rint;
+            char *lend, *rend;
+            lint = jim_strtoull(left, &lend);
+            rint = jim_strtoull(right, &rend);
+            if (lint != rint) {
+                return JimSign(lint - rint) * sort_info->order;
+            }
+            /* If the integers are equal but of unequal length, then one must have more leading
+             * zeros. The shorter one compares less */
+            if (lend -left != rend - right) {
+                return JimSign((lend - left) - (rend - right)) * sort_info->order;
+            }
+            left = lend;
+            right = rend;
+        }
+        else {
+            int cl, cr;
+            left += utf8_tounicode_case(left, &cl, 1);
+            right += utf8_tounicode_case(right, &cr, 1);
+            if (cl != cr) {
+                return JimSign(cl - cr) * sort_info->order;
+            }
+            if (cl == 0) {
+                /* If they compare equal, use a case sensitive comparison as a tie breaker */
+                return Jim_StringCompareObj(sort_info->interp, *lhsObj, *rhsObj, 0) * sort_info->order;
+            }
+        }
+    }
+}
+
 static int ListSortInteger(Jim_Obj **lhsObj, Jim_Obj **rhsObj)
 {
     jim_wide lhs = 0, rhs = 0;
@@ -7056,6 +7096,9 @@ static int ListSortElements(Jim_Interp *interp, Jim_Obj *listObjPtr, struct lsor
         case JIM_LSORT_COMMAND:
             fn = ListSortCommand;
             break;
+        case JIM_LSORT_DICT:
+            fn = ListSortDict;
+            break;
         default:
             fn = NULL;          /* avoid warning */
             JimPanic((1, "ListSort called with invalid sort type"));
@@ -13413,11 +13456,11 @@ static int Jim_LsortCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const arg
 {
     static const char * const options[] = {
         "-ascii", "-nocase", "-increasing", "-decreasing", "-command", "-integer", "-real", "-index", "-unique",
-        "-stride", NULL
+        "-stride", "-dictionary", NULL
     };
     enum {
         OPT_ASCII, OPT_NOCASE, OPT_INCREASING, OPT_DECREASING, OPT_COMMAND, OPT_INTEGER, OPT_REAL, OPT_INDEX, OPT_UNIQUE,
-        OPT_STRIDE
+        OPT_STRIDE, OPT_DICT
     };
     Jim_Obj *resObj;
     int i;
@@ -13452,6 +13495,9 @@ wrongargs:
             case OPT_ASCII:
                 info.type = JIM_LSORT_ASCII;
                 break;
+            case OPT_DICT:
+                info.type = JIM_LSORT_DICT;
+                break;
             case OPT_NOCASE:
                 info.type = JIM_LSORT_NOCASE;
                 break;
diff --git a/tests/lsort.test b/tests/lsort.test
index 5297568..4e5c2b3 100644
--- a/tests/lsort.test
+++ b/tests/lsort.test
@@ -17,7 +17,7 @@ test lsort-1.1 {Tcl_LsortObjCmd procedure} jim {
 } {1 {wrong # args: should be "lsort ?options? list"}}
 test lsort-1.2 {Tcl_LsortObjCmd procedure} jim {
     list [catch {lsort -foo {1 3 2 5}} msg] $msg
-} {1 {bad option "-foo": must be -ascii, -command, -decreasing, -increasing, -index, -integer, -nocase, -real, -stride, or -unique}}
+} {1 {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -integer, -nocase, -real, -stride, or -unique}}
 test lsort-1.3 {Tcl_LsortObjCmd procedure, default options} {
     lsort {d e c b a \{ d35 d300}
 } {a b c d d300 d35 e \{}
@@ -207,6 +207,12 @@ test lsort-5.1 "Sort case insensitive" {
     lsort -nocase {ba aB aa ce}
 } {aa aB ba ce}
 
+test cmdIL-1.8 {Tcl_LsortObjCmd procedure, -dictionary option} {
+    lsort -dictionary {d e c b a d35 d300}
+} {a b c d d35 d300 e}
+test cmdIL-1.9 {Tcl_LsortObjCmd procedure, -dictionary option} {
+    lsort -dictionary {1k 0k 10k}
+} {0k 1k 10k}
 test cmdIL-1.30 {Tcl_LsortObjCmd procedure, -stride option} {
     lsort -stride 2 {f e d c b a}
 } {b a d c f e}
@@ -237,5 +243,126 @@ test cmdIL-1.41 {lsort -stride and -index} -body {
 test cmdIL-1.42 {lsort -stride and-index} -body {
     lsort -stride 2 -index -1-1 {a 2 b 1}
 } -returnCodes error -result {index "-1-1" out of range}
+test cmdIL-3.8 {SortCompare procedure, -dictionary option} {
+    lsort -dictionary {d e c b a d35 d300 100 20}
+} {20 100 a b c d d35 d300 e}
+
+test cmdIL-4.1 {DictionaryCompare procedure, numerics, leading zeros} {
+    lsort -dictionary {a003b a03b}
+} {a03b a003b}
+test cmdIL-4.2 {DictionaryCompare procedure, numerics, leading zeros} {
+    lsort -dictionary {a3b a03b}
+} {a3b a03b}
+# This test fails in Jim because we don't bother falling back to a secondary
+# sort on case if the primary sort (with leading zeros) is equal.
+test cmdIL-4.3 {DictionaryCompare procedure, numerics, leading zeros} tcl {
+    lsort -dictionary {a3b A03b}
+} {A03b a3b}
+test cmdIL-4.4 {DictionaryCompare procedure, numerics, leading zeros} {
+    lsort -dictionary {a3b a03B}
+} {a3b a03B}
+test cmdIL-4.5 {DictionaryCompare procedure, numerics, leading zeros} {
+    lsort -dictionary {00000 000}
+} {000 00000}
+test cmdIL-4.6 {DictionaryCompare procedure, numerics, different lengths} {
+    lsort -dictionary {a321b a03210b}
+} {a321b a03210b}
+test cmdIL-4.7 {DictionaryCompare procedure, numerics, different lengths} {
+    lsort -dictionary {a03210b a321b}
+} {a321b a03210b}
+test cmdIL-4.8 {DictionaryCompare procedure, numerics} {
+    lsort -dictionary {48 6a 18b 22a 21aa 35 36}
+} {6a 18b 21aa 22a 35 36 48}
+test cmdIL-4.9 {DictionaryCompare procedure, numerics} {
+    lsort -dictionary {a123x a123b}
+} {a123b a123x}
+test cmdIL-4.10 {DictionaryCompare procedure, numerics} {
+    lsort -dictionary {a123b a123x}
+} {a123b a123x}
+test cmdIL-4.11 {DictionaryCompare procedure, numerics} {
+    lsort -dictionary {a1b aab}
+} {a1b aab}
+test cmdIL-4.12 {DictionaryCompare procedure, numerics} {
+    lsort -dictionary {a1b a!b}
+} {a!b a1b}
+test cmdIL-4.13 {DictionaryCompare procedure, numerics} {
+    lsort -dictionary {a1b2c a1b1c}
+} {a1b1c a1b2c}
+test cmdIL-4.14 {DictionaryCompare procedure, numerics} {
+    lsort -dictionary {a1b2c a1b3c}
+} {a1b2c a1b3c}
+test cmdIL-4.15 {DictionaryCompare procedure, long numbers} {
+    lsort -dictionary {a7654884321988762b a7654884321988761b}
+} {a7654884321988761b a7654884321988762b}
+test cmdIL-4.16 {DictionaryCompare procedure, long numbers} {
+    lsort -dictionary {a8765488432198876b a7654884321988761b}
+} {a7654884321988761b a8765488432198876b}
+test cmdIL-4.17 {DictionaryCompare procedure, case} {
+    lsort -dictionary {aBCd abcc}
+} {abcc aBCd}
+test cmdIL-4.18 {DictionaryCompare procedure, case} {
+    lsort -dictionary {aBCd abce}
+} {aBCd abce}
+test cmdIL-4.19 {DictionaryCompare procedure, case} {
+    lsort -dictionary {abcd ABcc}
+} {ABcc abcd}
+test cmdIL-4.20 {DictionaryCompare procedure, case} {
+    lsort -dictionary {abcd ABce}
+} {abcd ABce}
+test cmdIL-4.21 {DictionaryCompare procedure, case} {
+    lsort -dictionary {abCD ABcd}
+} {ABcd abCD}
+test cmdIL-4.22 {DictionaryCompare procedure, case} {
+    lsort -dictionary {ABcd aBCd}
+} {ABcd aBCd}
+test cmdIL-4.23 {DictionaryCompare procedure, case} {
+    lsort -dictionary {ABcd AbCd}
+} {ABcd AbCd}
+test cmdIL-4.24 {DictionaryCompare procedure, international characters} {
+    set result [lsort -dictionary "a b c A B C \xe3 \xc4"]
+    set result
+} "A a B b C c \xe3 \xc4"
+test cmdIL-4.25 {DictionaryCompare procedure, international characters} {
+    set result [lsort -dictionary "a23\xe3 a23\xc5 a23\xe4"]
+    set result
+} "a23\xe3 a23\xe4 a23\xc5"
+test cmdIL-4.26 {DefaultCompare procedure, signed characters} {
+    set l [lsort [list "abc\200" "abc"]]
+    set viewlist {}
+    foreach s $l {
+	set viewelem ""
+	set len [string length $s]
+	for {set i 0} {$i < $len} {incr i} {
+	    set c [string index $s $i]
+	    scan $c %c d
+	    if {$d > 0 && $d < 128} {
+		append viewelem $c
+	    } else {
+		append viewelem "\\[format %03o $d]"
+	    }
+	}
+	lappend viewlist $viewelem
+    }
+    set viewlist
+} [list "abc" "abc\\200"]
+test cmdIL-4.27 {DictionaryCompare procedure, signed characters} {
+    set l [lsort -dictionary [list "abc\200" "abc"]]
+    set viewlist {}
+    foreach s $l {
+	set viewelem ""
+	set len [string length $s]
+	for {set i 0} {$i < $len} {incr i} {
+	    set c [string index $s $i]
+	    scan $c %c d
+	    if {$d > 0 && $d < 128} {
+		append viewelem $c
+	    } else {
+		append viewelem "\\[format %03o $d]"
+	    }
+	}
+	lappend viewlist $viewelem
+    }
+    set viewlist
+} [list "abc" "abc\\200"]
 
 testreport