SQLite4  Check-in [6ebe82280d]

/*
** New collation sequences function can be created as TCL scripts.  Each such
** function is described by an instance of the following structure.
*/
typedef struct SqlCollate SqlCollate;
struct SqlCollate {
  Tcl_Interp *interp;   /* The TCL interpret to execute the function */
  char *zCmp;           /* The script to compare two values */
  char *zMkkey;         /* The script to encode a key value */
  SqlCollate *pNext;    /* Next function on the list of them all */
};

/*
** Prepared statements are cached for faster execution.  Each prepared
** statement is described by an instance of the following structure.
*/

  const void *zA,
  int nB,
  const void *zB
){
  SqlCollate *p = (SqlCollate *)pCtx;
  Tcl_Obj *pCmd;

  pCmd = Tcl_NewStringObj(p->zCmp, -1);
  Tcl_IncrRefCount(pCmd);
  Tcl_ListObjAppendElement(p->interp, pCmd, Tcl_NewStringObj(zA, nA));
  Tcl_ListObjAppendElement(p->interp, pCmd, Tcl_NewStringObj(zB, nB));
  Tcl_EvalObjEx(p->interp, pCmd, TCL_EVAL_DIRECT);
  Tcl_DecrRefCount(pCmd);
  return (atoi(Tcl_GetStringResult(p->interp)));
}

static int tclSqlMkkey(
  void *pCtx,
  int nIn,
  const void *zIn,
  int nOut,
  void *zOut
){
  SqlCollate *p = (SqlCollate *)pCtx;
  Tcl_Obj *pCmd;
  int nRes;
  char *zRes;

  pCmd = Tcl_NewStringObj(p->zMkkey, -1);
  Tcl_IncrRefCount(pCmd);
  Tcl_ListObjAppendElement(p->interp, pCmd, Tcl_NewStringObj(zIn, nIn));
  Tcl_EvalObjEx(p->interp, pCmd, TCL_EVAL_DIRECT);
  Tcl_DecrRefCount(pCmd);

  zRes = Tcl_GetStringFromObj(Tcl_GetObjResult(p->interp), &nRes);
  if( nRes<=nOut ){
    memcpy(zOut, zRes, nRes);
  }
  return nRes;
}

/*
** This routine is called to evaluate an SQL function implemented
** using TCL script.
*/
static void tclSqlFunc(sqlite4_context *context, int argc, sqlite4_value**argv){
  SqlFunc *p = sqlite4_user_data(context);

  */
  case DB_CLOSE: {
    Tcl_DeleteCommand(interp, Tcl_GetStringFromObj(objv[0], 0));
    break;
  }

  /*
  **     $db collate NAME COMPARE-SCRIPT MKKEY-SCRIPT
  **
  ** Create a new SQL collation function called NAME.  Whenever
  ** that function is called, invoke SCRIPT to evaluate the function.
  */
  case DB_COLLATE: {
    SqlCollate *pCollate;
    char *zName;
    char *zCmp; int nCmp;
    char *zMkkey; int nMkkey;
    int nByte;

    if( objc!=5 ){
      Tcl_WrongNumArgs(interp, 2, objv, "NAME CMP-SCRIPT MKKEY-SCRIPT");
      return TCL_ERROR;
    }
    zName = Tcl_GetStringFromObj(objv[2], 0);
    zCmp = Tcl_GetStringFromObj(objv[3], &nCmp);
    zMkkey = Tcl_GetStringFromObj(objv[4], &nMkkey);

    nByte = sizeof(SqlCollate) + nCmp + 1 + nMkkey + 1;
    pCollate = (SqlCollate*)Tcl_Alloc(nByte);

    pCollate->interp = interp;
    pCollate->pNext = pDb->pCollate;
    pCollate->zCmp = (char*)&pCollate[1];
    pCollate->zMkkey = &pCollate->zCmp[nCmp + 1];
    pDb->pCollate = pCollate;

    memcpy(pCollate->zCmp, zCmp, nCmp+1);
    memcpy(pCollate->zMkkey, zMkkey, nMkkey+1);
    if( sqlite4_create_collation(pDb->db, zName, SQLITE_UTF8, 
        pCollate, tclSqlCollate, tclSqlMkkey, 0) ){
      Tcl_SetResult(interp, (char *)sqlite4_errmsg(pDb->db), TCL_VOLATILE);
      return TCL_ERROR;
    }
    break;
  }

  /*

# collate1-1.* - Single-field ORDER BY with an explicit COLLATE clause.
# collate1-2.* - Multi-field ORDER BY with an explicit COLLATE clause.
# collate1-3.* - ORDER BY using a default collation type. Also that an 
#                explict collate type overrides a default collate type.
# collate1-4.* - ORDER BY using a data type.
#

#-------------------------------------------------------------------------
# Collation type 'HEX'. If an argument can be interpreted as a hexadecimal
# number, then it is converted to one before the comparison is performed. 
# Hex numbers are less than other strings. If neither argument is a 
# number, [string compare] is used.
#
db collate HEX hex_collate hex_mkkey
proc hex_collate {lhs rhs} {
  set lhs_ishex [regexp {^(0x|)[1234567890abcdefABCDEF]+$} $lhs]
  set rhs_ishex [regexp {^(0x|)[1234567890abcdefABCDEF]+$} $rhs]
  if {$lhs_ishex && $rhs_ishex} { 
    set lhsx [scan $lhs %x]
    set rhsx [scan $rhs %x]
    if {$lhs < $rhs} {return -1}
    if {$lhs == $rhs} {return 0}
    if {$lhs > $rhs} {return 1}
  }
  if {$lhs_ishex} {
    return -1;
  }
  if {$rhs_ishex} {
    return 1;
  }
  return [string compare $lhs $rhs]
}

proc hex_mkkey {zIn} {
  set ishex [regexp {^(0x|)[1234567890abcdefABCDEF]+$} $zIn]
  if {$ishex==0} {
    set res "b_$zIn"
  } else {
    set num [scan $zIn %x]
    set res [format "a_%024d" $num]
  }
  return $res
}

db function hex {format 0x%X}

#-------------------------------------------------------------------------
# Mimic the SQLite 2 collation type NUMERIC. Sort of. Use the following
# rules:
#
#   * If [string is integer] says both sides of a comparison are integers,
#     do an integer comparison.
#
#   * If one side is an integer and the other not, the integer is less
#     than the other value.
#
#   * Otherwise, if neither side is an integer, do a memcmp() comparison.
#
db collate numeric numeric_collate numeric_mkkey
proc numeric_collate {lhs rhs} {
  set lhs_isint [string is integer $lhs]
  set rhs_isint [string is integer $rhs]

  if {$lhs_isint && $rhs_isint} { return [expr $lhs - $rhs] }
  if {$lhs_isint != $rhs_isint} { return [expr $rhs_isint - $lhs_isint] }
  return [string compare $lhs $rhs]
}
proc numeric_mkkey {zIn} {
  if {[string is integer $zIn]} {
    set res [format "a_%024d" $zIn]
  } else {
    set res "b_$zIn"
  }
  return $res
}

do_test collate1-1.0 {
  execsql {
    CREATE TABLE collate1t1(c1, c2);
    INSERT INTO collate1t1 VALUES(45, hex(45));
    INSERT INTO collate1t1 VALUES(NULL, NULL);

#
lappend ::testsuitelist xxx

test_suite "src4" -prefix "" -description {
} -files {
  simple.test fkey1.test conflict.test trigger2.test select1.test
  where.test select3.test select5.test select7.test select8.test
  select9.test selectA.test selectB.test selectC.test

  collate1.test
}

test_suite "veryquick" -prefix "" -description {
  "Very" quick test suite. Runs in less than 5 minutes on a workstation. 
  This test suite is the same as the "quick" tests, except that some files
  that test malloc and IO errors are omitted.
} -files [

    DROP INDEX i1;
    DROP INDEX i2;
    DROP INDEX i3;
    DROP INDEX i4;
  }
} {}

proc reverse_cmp {lhs rhs} {
  return [string compare $rhs $lhs]
}

proc reverse_mkkey {zIn} {
  set res ""
  binary scan $zIn c* lChar
  foreach c $lChar {
    append res [format "%02X" [expr 255-$c]]
  }
  set res
}

db collate reverse reverse_cmp reverse_mkkey

# This loop is similar to the previous one (test cases select9-1.*) 
# except that the simple select statements have WHERE clauses attached
# to them. Sometimes the WHERE clause may be satisfied using the same
# index used for ORDER BY, sometimes not.
#
set iOuterLoop 1

}
do_execsql_test 47.2 {
  SELECT x FROM t1 ORDER BY x;
} {B D a c}
do_execsql_test 47.3 {
  SELECT x FROM t1 ORDER BY x COLLATE nocase;
} {a B c D}

#-------------------------------------------------------------------------
reset_db
do_execsql_test 48.1 {
  CREATE TABLE t1(a, b, c);
  CREATE TABLE t2(d, e, f);
  BEGIN;
  INSERT INTO t1 VALUES(1,  'one',   'I');
  INSERT INTO t1 VALUES(3,  NULL,    NULL);
  INSERT INTO t1 VALUES(5,  'five',  'V');
  INSERT INTO t1 VALUES(7,  'seven', 'VII');
  INSERT INTO t1 VALUES(9,  NULL,    NULL);
  INSERT INTO t1 VALUES(2,  'two',   'II');
  INSERT INTO t1 VALUES(4,  'four',  'IV');
  INSERT INTO t1 VALUES(6,  NULL,    NULL);
  INSERT INTO t1 VALUES(8,  'eight', 'VIII');
  INSERT INTO t1 VALUES(10, 'ten',   'X');

  INSERT INTO t2 VALUES(1,  'two',      'IV');
  INSERT INTO t2 VALUES(2,  'four',     'VIII');
  INSERT INTO t2 VALUES(3,  NULL,       NULL);
  INSERT INTO t2 VALUES(4,  'eight',    'XVI');
  INSERT INTO t2 VALUES(5,  'ten',      'XX');
  INSERT INTO t2 VALUES(6,  NULL,       NULL);
  INSERT INTO t2 VALUES(7,  'fourteen', 'XXVIII');
  INSERT INTO t2 VALUES(8,  'sixteen',  'XXXII');
  INSERT INTO t2 VALUES(9,  NULL,       NULL);
  INSERT INTO t2 VALUES(10, 'twenty',   'XL');

  COMMIT;
}

do_execsql_test 48.2 {
  SELECT a, b FROM t1 UNION ALL SELECT d, e FROM t2 ORDER BY 1 
} {
  1 one 1 two 2 two 2 four 3 
  {} 3 {} 4 four 4 eight 5 
  five 5 ten 6 {} 6 {} 7 
  seven 7 fourteen 8 eight 8 sixteen 9 
  {} 9 {} 10 ten 10 twenty
}

proc reverse_cmp {lhs rhs} {
  return [string compare $rhs $lhs]
}
proc reverse_mkkey {zIn} {
  set res ""
  binary scan $zIn c* lChar
  foreach c $lChar {
    append res [format "%02X" [expr 255-$c]]
  }
  set res
}
db collate reverse reverse_cmp reverse_mkkey

do_execsql_test 48.3 {
    SELECT * FROM t1 WHERE a<5 UNION SELECT * FROM t2 WHERE d>=5 
    ORDER BY 2 COLLATE reverse, 1
} { 
  3 {} {}            6 {} {}         9 {} {} 
  2 two II           10 twenty XL    5 ten XX 
  8 sixteen XXXII    1 one I         7 fourteen XXVIII 
  4 four IV
}

finish_test