test/tclsqlite.test

# 2001 September 15
#
# The author disclaims copyright to this source code.  In place of
# a legal notice, here is a blessing:
#
#    May you do good and not evil.
#    May you find forgiveness for yourself and forgive others.
#    May you share freely, never taking more than you give.
#
#***********************************************************************
# This file implements regression tests for TCL interface to the
# SQLite library. 
#
# Actually, all tests are based on the TCL interface, so the main
# interface is pretty well tested.  This file contains some addition
# tests for fringe issues that the main test suite does not cover.
#
# $Id: tclsqlite.test,v 1.33 2004/11/03 16:27:02 drh Exp $

set testdir [file dirname $argv0]
source $testdir/tester.tcl

# Check the error messages generated by tclsqlite
#
if {[sqlite3 -has-codec]} {
  set r "sqlite_orig HANDLE FILENAME ?-key CODEC-KEY?"
} else {
  set r "sqlite3 HANDLE FILENAME ?MODE?"
}
do_test tcl-1.1 {
  set v [catch {sqlite3 bogus} msg]
  lappend v $msg
} [list 1 "wrong # args: should be \"$r\""]
do_test tcl-1.2 {
  set v [catch {db bogus} msg]
  lappend v $msg
} {1 {bad option "bogus": must be authorizer, busy, changes, close, collate, collation_needed, commit_hook, complete, errorcode, eval, function, last_insert_rowid, onecolumn, progress, rekey, timeout, total_changes, or trace}}
do_test tcl-1.3 {
  execsql {CREATE TABLE t1(a int, b int)}
  execsql {INSERT INTO t1 VALUES(10,20)}
  set v [catch {
    db eval {SELECT * FROM t1} data {
      error "The error message"
    }
  } msg]
  lappend v $msg
} {1 {The error message}}
do_test tcl-1.4 {
  set v [catch {
    db eval {SELECT * FROM t2} data {
      error "The error message"
    }
  } msg]
  lappend v $msg
} {1 {no such table: t2}}
do_test tcl-1.5 {
  set v [catch {
    db eval {SELECT * FROM t1} data {
      break
    }
  } msg]
  lappend v $msg
} {0 {}}
do_test tcl-1.6 {
  set v [catch {
    db eval {SELECT * FROM t1} data {
      expr x*
    }
  } msg]
  regsub {:.*$} $msg {} msg
  lappend v $msg
} {1 {syntax error in expression "x*"}}
do_test tcl-1.7 {
  set v [catch {db} msg]
  lappend v $msg
} {1 {wrong # args: should be "db SUBCOMMAND ..."}}
if {[catch {db auth {}}]==0} {
  do_test tcl-1.8 {
    set v [catch {db authorizer 1 2 3} msg]
    lappend v $msg
  } {1 {wrong # args: should be "db authorizer ?CALLBACK?"}}
}
do_test tcl-1.9 {
  set v [catch {db busy 1 2 3} msg]
  lappend v $msg
} {1 {wrong # args: should be "db busy CALLBACK"}}
do_test tcl-1.10 {
  set v [catch {db progress 1} msg]
  lappend v $msg
} {1 {wrong # args: should be "db progress N CALLBACK"}}
do_test tcl-1.11 {
  set v [catch {db changes xyz} msg]
  lappend v $msg
} {1 {wrong # args: should be "db changes "}}
do_test tcl-1.12 {
  set v [catch {db commit_hook a b c} msg]
  lappend v $msg
} {1 {wrong # args: should be "db commit_hook ?CALLBACK?"}}
do_test tcl-1.13 {
  set v [catch {db complete} msg]
  lappend v $msg
} {1 {wrong # args: should be "db complete SQL"}}
do_test tcl-1.14 {
  set v [catch {db eval} msg]
  lappend v $msg
} {1 {wrong # args: should be "db eval SQL ?ARRAY-NAME? ?SCRIPT?"}}
do_test tcl-1.15 {
  set v [catch {db function} msg]
  lappend v $msg
} {1 {wrong # args: should be "db function NAME SCRIPT"}}
do_test tcl-1.14 {
  set v [catch {db last_insert_rowid xyz} msg]
  lappend v $msg
} {1 {wrong # args: should be "db last_insert_rowid "}}
do_test tcl-1.15 {
  set v [catch {db rekey} msg]
  lappend v $msg
} {1 {wrong # args: should be "db rekey KEY"}}
do_test tcl-1.16 {
  set v [catch {db timeout} msg]
  lappend v $msg
} {1 {wrong # args: should be "db timeout MILLISECONDS"}}
do_test tcl-1.17 {
  set v [catch {db collate} msg]
  lappend v $msg
} {1 {wrong # args: should be "db collate NAME SCRIPT"}}
do_test tcl-1.18 {
  set v [catch {db collation_needed} msg]
  lappend v $msg
} {1 {wrong # args: should be "db collation_needed SCRIPT"}}
do_test tcl-1.19 {
  set v [catch {db total_changes xyz} msg]
  lappend v $msg
} {1 {wrong # args: should be "db total_changes "}}


if {[sqlite3 -tcl-uses-utf]} {
  catch {unset ::result}
  do_test tcl-2.1 {
    execsql "CREATE TABLE t\u0123x(a int, b\u1235 float)"
    execsql "PRAGMA table_info(t\u0123x)"
  } "0 a int 0 {} 0 1 b\u1235 float 0 {} 0"
  do_test tcl-2.2 {
    execsql "INSERT INTO t\u0123x VALUES(1,2.3)"
    db eval "SELECT * FROM t\u0123x" result break
    set result(*)
  } "a b\u1235"
}


# Test the onecolumn method
#
do_test tcl-3.1 {
  execsql {
    INSERT INTO t1 SELECT a*2, b*2 FROM t1;
    INSERT INTO t1 SELECT a*2+1, b*2+1 FROM t1;
    INSERT INTO t1 SELECT a*2+3, b*2+3 FROM t1;
  }
  set rc [catch {db onecolumn {SELECT * FROM t1 ORDER BY a}} msg]
  lappend rc $msg
} {0 10}
do_test tcl-3.2 {
  db onecolumn {SELECT * FROM t1 WHERE a<0}
} {}
do_test tcl-3.3 {
  set rc [catch {db onecolumn} errmsg]
  lappend rc $errmsg
} {1 {wrong # args: should be "db onecolumn SQL"}}
do_test tcl-3.4 {
  set rc [catch {db onecolumn {SELECT bogus}} errmsg]
  lappend rc $errmsg
} {1 {no such column: bogus}}
ifcapable {tclvar} {
  do_test tcl-3.5 {
    set b 50
    set rc [catch {db one {SELECT * FROM t1 WHERE b>$b}} msg]
    lappend rc $msg
  } {0 41}
  do_test tcl-3.6 {
    set b 500
    set rc [catch {db one {SELECT * FROM t1 WHERE b>$b}} msg]
    lappend rc $msg
  } {0 {}}
  do_test tcl-3.7 {
    set b 500
    set rc [catch {db one {
      INSERT INTO t1 VALUES(99,510);
      SELECT * FROM t1 WHERE b>$b
    }} msg]
    lappend rc $msg
  } {0 99}
}
ifcapable {!tclvar} {
   execsql {INSERT INTO t1 VALUES(99,510)}
}

# Turn the busy handler on and off
#
do_test tcl-4.1 {
  proc busy_callback {cnt} {
    break
  }
  db busy busy_callback
  db busy
} {busy_callback}
do_test tcl-4.2 {
  db busy {}
  db busy
} {}

ifcapable {tclvar} {
  # Parsing of TCL variable names within SQL into bound parameters.
  #
  do_test tcl-5.1 {
    execsql {CREATE TABLE t3(a,b,c)}
    catch {unset x}
    set x(1) 5
    set x(2) 7
    execsql {
      INSERT INTO t3 VALUES($::x(1),$::x(2),$::x(3));
      SELECT * FROM t3
    }
  } {5 7 {}}
  do_test tcl-5.2 {
    execsql {
      SELECT typeof(a), typeof(b), typeof(c) FROM t3
    }
  } {text text null}
  do_test tcl-5.3 {
    catch {unset x}
    set x [binary format h12 686900686f00]
    execsql {
      UPDATE t3 SET a=$::x;
    }
    db eval {
      SELECT a FROM t3
    } break
    binary scan $a h12 adata
    set adata
  } {686900686f00}
  do_test tcl-5.4 {
    execsql {
      SELECT typeof(a), typeof(b), typeof(c) FROM t3
    }
  } {blob text null}
}

# Operation of "break" and "continue" within row scripts
#
do_test tcl-6.1 {
  db eval {SELECT * FROM t1} {
    break
  }
  lappend a $b
} {10 20}
do_test tcl-6.2 {
  set cnt 0
  db eval {SELECT * FROM t1} {
    if {$a>40} continue
    incr cnt
  }
  set cnt
} {4}
do_test tcl-6.3 {
  set cnt 0
  db eval {SELECT * FROM t1} {
    if {$a<40} continue
    incr cnt
  }
  set cnt
} {5}
do_test tcl-6.4 {
  proc return_test {x} {
    db eval {SELECT * FROM t1} {
      if {$a==$x} {return $b}
    }
  }
  return_test 10
} 20
do_test tcl-6.5 {
  return_test 20
} 40
do_test tcl-6.6 {
  return_test 99
} 510
do_test tcl-6.7 {
  return_test 0
} {}

finish_test