4 ** The author disclaims copyright to this source code. In place of
5 ** a legal notice, here is a blessing:
7 ** May you do good and not evil.
8 ** May you find forgiveness for yourself and forgive others.
9 ** May you share freely, never taking more than you give.
11 *************************************************************************
12 ** Code for testing the virtual table interfaces. This code
13 ** is not included in the SQLite library. It is used for automated
14 ** testing of the SQLite library.
16 ** The emphasis of this file is a virtual table that provides
17 ** access to TCL variables.
19 ** The TCLVAR eponymous virtual table has a schema like this:
21 ** CREATE TABLE tclvar(
22 ** name TEXT, -- base name of the variable: "x" in "$x(y)"
23 ** arrayname TEXT, -- array index name: "y" in "$x(y)"
24 ** value TEXT, -- the value of the variable
25 ** fullname TEXT, -- the full name of the variable
26 ** PRIMARY KEY(fullname)
29 ** DELETE, INSERT, and UPDATE operations use the "fullname" field to
30 ** determine the variable to be modified. Changing "value" to NULL
31 ** deletes the variable.
33 ** For SELECT operations, the "name" and "arrayname" fields will always
34 ** match the "fullname" field. For DELETE, INSERT, and UPDATE, the
35 ** "name" and "arrayname" fields are ignored and the variable is modified
36 ** according to "fullname" and "value" only.
38 #include "sqliteInt.h"
39 #if defined(INCLUDE_SQLITE_TCL_H)
40 # include "sqlite_tcl.h"
47 #ifndef SQLITE_OMIT_VIRTUALTABLE
50 ** Characters that make up the idxStr created by xBestIndex for xFilter.
52 #define TCLVAR_NAME_EQ 'e'
53 #define TCLVAR_NAME_MATCH 'm'
54 #define TCLVAR_VALUE_GLOB 'g'
55 #define TCLVAR_VALUE_REGEXP 'r'
56 #define TCLVAR_VALUE_LIKE 'l'
58 typedef struct tclvar_vtab tclvar_vtab
;
59 typedef struct tclvar_cursor tclvar_cursor
;
62 ** A tclvar virtual-table object
69 /* A tclvar cursor object */
70 struct tclvar_cursor
{
71 sqlite3_vtab_cursor base
;
73 Tcl_Obj
*pList1
; /* Result of [info vars ?pattern?] */
74 Tcl_Obj
*pList2
; /* Result of [array names [lindex $pList1 $i1]] */
75 int i1
; /* Current item in pList1 */
76 int i2
; /* Current item (if any) in pList2 */
79 /* Methods for the tclvar module */
80 static int tclvarConnect(
83 int argc
, const char *const*argv
,
84 sqlite3_vtab
**ppVtab
,
88 static const char zSchema
[] =
90 " name TEXT," /* Base name */
91 " arrayname TEXT," /* Array index */
92 " value TEXT," /* Value */
93 " fullname TEXT PRIMARY KEY" /* base(index) name */
95 pVtab
= sqlite3MallocZero( sizeof(*pVtab
) );
96 if( pVtab
==0 ) return SQLITE_NOMEM
;
97 *ppVtab
= &pVtab
->base
;
98 pVtab
->interp
= (Tcl_Interp
*)pAux
;
99 sqlite3_declare_vtab(db
, zSchema
);
102 /* Note that for this virtual table, the xCreate and xConnect
103 ** methods are identical. */
105 static int tclvarDisconnect(sqlite3_vtab
*pVtab
){
109 /* The xDisconnect and xDestroy methods are also the same */
112 ** Open a new tclvar cursor.
114 static int tclvarOpen(sqlite3_vtab
*pVTab
, sqlite3_vtab_cursor
**ppCursor
){
116 pCur
= sqlite3MallocZero(sizeof(tclvar_cursor
));
117 *ppCursor
= &pCur
->base
;
122 ** Close a tclvar cursor.
124 static int tclvarClose(sqlite3_vtab_cursor
*cur
){
125 tclvar_cursor
*pCur
= (tclvar_cursor
*)cur
;
127 Tcl_DecrRefCount(pCur
->pList1
);
130 Tcl_DecrRefCount(pCur
->pList2
);
137 ** Returns 1 if data is ready, or 0 if not.
139 static int next2(Tcl_Interp
*interp
, tclvar_cursor
*pCur
, Tcl_Obj
*pObj
){
144 p
= Tcl_NewStringObj("array names", -1);
146 Tcl_ListObjAppendElement(0, p
, pObj
);
147 Tcl_EvalObjEx(interp
, p
, TCL_EVAL_GLOBAL
);
149 pCur
->pList2
= Tcl_GetObjResult(interp
);
150 Tcl_IncrRefCount(pCur
->pList2
);
151 assert( pCur
->i2
==0 );
155 Tcl_ListObjLength(0, pCur
->pList2
, &n
);
157 Tcl_DecrRefCount(pCur
->pList2
);
168 static int tclvarNext(sqlite3_vtab_cursor
*cur
){
173 tclvar_cursor
*pCur
= (tclvar_cursor
*)cur
;
174 Tcl_Interp
*interp
= ((tclvar_vtab
*)(cur
->pVtab
))->interp
;
176 Tcl_ListObjLength(0, pCur
->pList1
, &n
);
177 while( !ok
&& pCur
->i1
<n
){
178 Tcl_ListObjIndex(0, pCur
->pList1
, pCur
->i1
, &pObj
);
179 ok
= next2(interp
, pCur
, pObj
);
188 static int tclvarFilter(
189 sqlite3_vtab_cursor
*pVtabCursor
,
190 int idxNum
, const char *idxStr
,
191 int argc
, sqlite3_value
**argv
193 tclvar_cursor
*pCur
= (tclvar_cursor
*)pVtabCursor
;
194 Tcl_Interp
*interp
= ((tclvar_vtab
*)(pVtabCursor
->pVtab
))->interp
;
195 Tcl_Obj
*p
= Tcl_NewStringObj("tclvar_filter_cmd", -1);
197 const char *zEq
= "";
198 const char *zMatch
= "";
199 const char *zGlob
= "";
200 const char *zRegexp
= "";
201 const char *zLike
= "";
204 for(i
=0; idxStr
[i
]; i
++){
207 zEq
= (const char*)sqlite3_value_text(argv
[i
]);
209 case TCLVAR_NAME_MATCH
:
210 zMatch
= (const char*)sqlite3_value_text(argv
[i
]);
212 case TCLVAR_VALUE_GLOB
:
213 zGlob
= (const char*)sqlite3_value_text(argv
[i
]);
215 case TCLVAR_VALUE_REGEXP
:
216 zRegexp
= (const char*)sqlite3_value_text(argv
[i
]);
218 case TCLVAR_VALUE_LIKE
:
219 zLike
= (const char*)sqlite3_value_text(argv
[i
]);
227 Tcl_ListObjAppendElement(0, p
, Tcl_NewStringObj(zEq
, -1));
228 Tcl_ListObjAppendElement(0, p
, Tcl_NewStringObj(zMatch
, -1));
229 Tcl_ListObjAppendElement(0, p
, Tcl_NewStringObj(zGlob
, -1));
230 Tcl_ListObjAppendElement(0, p
, Tcl_NewStringObj(zRegexp
, -1));
231 Tcl_ListObjAppendElement(0, p
, Tcl_NewStringObj(zLike
, -1));
233 Tcl_EvalObjEx(interp
, p
, TCL_EVAL_GLOBAL
);
235 Tcl_DecrRefCount(pCur
->pList1
);
238 Tcl_DecrRefCount(pCur
->pList2
);
243 pCur
->pList1
= Tcl_GetObjResult(interp
);
244 Tcl_IncrRefCount(pCur
->pList1
);
247 return tclvarNext(pVtabCursor
);
250 static int tclvarColumn(sqlite3_vtab_cursor
*cur
, sqlite3_context
*ctx
, int i
){
255 tclvar_cursor
*pCur
= (tclvar_cursor
*)cur
;
256 Tcl_Interp
*interp
= ((tclvar_vtab
*)cur
->pVtab
)->interp
;
258 Tcl_ListObjIndex(interp
, pCur
->pList1
, pCur
->i1
, &p1
);
259 Tcl_ListObjIndex(interp
, pCur
->pList2
, pCur
->i2
, &p2
);
260 z1
= Tcl_GetString(p1
);
262 z2
= Tcl_GetString(p2
);
266 sqlite3_result_text(ctx
, z1
, -1, SQLITE_TRANSIENT
);
270 sqlite3_result_text(ctx
, z2
, -1, SQLITE_TRANSIENT
);
274 Tcl_Obj
*pVal
= Tcl_GetVar2Ex(interp
, z1
, *z2
?z2
:0, TCL_GLOBAL_ONLY
);
275 sqlite3_result_text(ctx
, Tcl_GetString(pVal
), -1, SQLITE_TRANSIENT
);
281 z3
= sqlite3_mprintf("%s(%s)", z1
, z2
);
282 sqlite3_result_text(ctx
, z3
, -1, sqlite3_free
);
284 sqlite3_result_text(ctx
, z1
, -1, SQLITE_TRANSIENT
);
292 static int tclvarRowid(sqlite3_vtab_cursor
*cur
, sqlite_int64
*pRowid
){
297 static int tclvarEof(sqlite3_vtab_cursor
*cur
){
298 tclvar_cursor
*pCur
= (tclvar_cursor
*)cur
;
299 return (pCur
->pList2
?0:1);
303 ** If nul-terminated string zStr does not already contain the character
304 ** passed as the second argument, append it and return 0. Or, if there is
305 ** already an instance of x in zStr, do nothing return 1;
307 ** There is guaranteed to be enough room in the buffer pointed to by zStr
308 ** for the new character and nul-terminator.
310 static int tclvarAddToIdxstr(char *zStr
, char x
){
312 for(i
=0; zStr
[i
]; i
++){
313 if( zStr
[i
]==x
) return 1;
321 ** Return true if variable $::tclvar_set_omit exists and is set to true.
324 static int tclvarSetOmit(Tcl_Interp
*interp
){
328 rc
= Tcl_Eval(interp
,
329 "expr {[info exists ::tclvar_set_omit] && $::tclvar_set_omit}"
332 pRes
= Tcl_GetObjResult(interp
);
333 rc
= Tcl_GetBooleanFromObj(0, pRes
, &res
);
335 return (rc
==TCL_OK
&& res
);
339 ** The xBestIndex() method. This virtual table supports the following
342 ** name = ? (omit flag clear)
343 ** name MATCH ? (omit flag set)
344 ** value GLOB ? (omit flag set iff $::tclvar_set_omit)
345 ** value REGEXP ? (omit flag set iff $::tclvar_set_omit)
346 ** value LIKE ? (omit flag set iff $::tclvar_set_omit)
348 ** For each constraint present, the corresponding TCLVAR_XXX character is
349 ** appended to the idxStr value.
351 static int tclvarBestIndex(sqlite3_vtab
*tab
, sqlite3_index_info
*pIdxInfo
){
352 tclvar_vtab
*pTab
= (tclvar_vtab
*)tab
;
354 char *zStr
= sqlite3_malloc(32);
357 if( zStr
==0 ) return SQLITE_NOMEM
;
360 for(ii
=0; ii
<pIdxInfo
->nConstraint
; ii
++){
361 struct sqlite3_index_constraint
const *pCons
= &pIdxInfo
->aConstraint
[ii
];
362 struct sqlite3_index_constraint_usage
*pUsage
;
364 pUsage
= &pIdxInfo
->aConstraintUsage
[ii
];
367 if( pCons
->op
==SQLITE_INDEX_CONSTRAINT_EQ
&& pCons
->iColumn
==0 ){
368 if( 0==tclvarAddToIdxstr(zStr
, TCLVAR_NAME_EQ
) ){
369 pUsage
->argvIndex
= ++iStr
;
375 if( pCons
->op
==SQLITE_INDEX_CONSTRAINT_MATCH
&& pCons
->iColumn
==0 ){
376 if( 0==tclvarAddToIdxstr(zStr
, TCLVAR_NAME_MATCH
) ){
377 pUsage
->argvIndex
= ++iStr
;
383 if( pCons
->op
==SQLITE_INDEX_CONSTRAINT_GLOB
&& pCons
->iColumn
==2 ){
384 if( 0==tclvarAddToIdxstr(zStr
, TCLVAR_VALUE_GLOB
) ){
385 pUsage
->argvIndex
= ++iStr
;
386 pUsage
->omit
= tclvarSetOmit(pTab
->interp
);
391 if( pCons
->op
==SQLITE_INDEX_CONSTRAINT_REGEXP
&& pCons
->iColumn
==2 ){
392 if( 0==tclvarAddToIdxstr(zStr
, TCLVAR_VALUE_REGEXP
) ){
393 pUsage
->argvIndex
= ++iStr
;
394 pUsage
->omit
= tclvarSetOmit(pTab
->interp
);
399 if( pCons
->op
==SQLITE_INDEX_CONSTRAINT_LIKE
&& pCons
->iColumn
==2 ){
400 if( 0==tclvarAddToIdxstr(zStr
, TCLVAR_VALUE_LIKE
) ){
401 pUsage
->argvIndex
= ++iStr
;
402 pUsage
->omit
= tclvarSetOmit(pTab
->interp
);
407 pIdxInfo
->idxStr
= zStr
;
408 pIdxInfo
->needToFreeIdxStr
= 1;
414 ** Invoked for any UPDATE, INSERT, or DELETE against a tclvar table
416 static int tclvarUpdate(
419 sqlite3_value
**argv
,
422 tclvar_vtab
*pTab
= (tclvar_vtab
*)tab
;
424 /* A DELETE operation. The variable to be deleted is stored in argv[0] */
425 const char *zVar
= (const char*)sqlite3_value_text(argv
[0]);
426 Tcl_UnsetVar(pTab
->interp
, zVar
, TCL_GLOBAL_ONLY
);
429 if( sqlite3_value_type(argv
[0])==SQLITE_NULL
){
430 /* An INSERT operation */
431 const char *zValue
= (const char*)sqlite3_value_text(argv
[4]);
433 if( sqlite3_value_type(argv
[5])!=SQLITE_TEXT
){
434 tab
->zErrMsg
= sqlite3_mprintf("the 'fullname' column must be TEXT");
437 zName
= (const char*)sqlite3_value_text(argv
[5]);
439 Tcl_SetVar(pTab
->interp
, zName
, zValue
, TCL_GLOBAL_ONLY
);
441 Tcl_UnsetVar(pTab
->interp
, zName
, TCL_GLOBAL_ONLY
);
445 if( sqlite3_value_type(argv
[0])==SQLITE_TEXT
446 && sqlite3_value_type(argv
[1])==SQLITE_TEXT
448 /* An UPDATE operation */
449 const char *zOldName
= (const char*)sqlite3_value_text(argv
[0]);
450 const char *zNewName
= (const char*)sqlite3_value_text(argv
[1]);
451 const char *zValue
= (const char*)sqlite3_value_text(argv
[4]);
453 if( strcmp(zOldName
, zNewName
)!=0 || zValue
==0 ){
454 Tcl_UnsetVar(pTab
->interp
, zOldName
, TCL_GLOBAL_ONLY
);
457 Tcl_SetVar(pTab
->interp
, zNewName
, zValue
, TCL_GLOBAL_ONLY
);
461 tab
->zErrMsg
= sqlite3_mprintf("prohibited TCL variable change");
466 ** A virtual table module that provides read-only access to a
467 ** Tcl global variable namespace.
469 static sqlite3_module tclvarModule
= {
476 tclvarOpen
, /* xOpen - open a cursor */
477 tclvarClose
, /* xClose - close a cursor */
478 tclvarFilter
, /* xFilter - configure scan constraints */
479 tclvarNext
, /* xNext - advance a cursor */
480 tclvarEof
, /* xEof - check for end of scan */
481 tclvarColumn
, /* xColumn - read data */
482 tclvarRowid
, /* xRowid - read data */
483 tclvarUpdate
, /* xUpdate */
493 ** Decode a pointer to an sqlite3 object.
495 extern int getDbPointer(Tcl_Interp
*interp
, const char *zA
, sqlite3
**ppDb
);
498 ** Register the echo virtual table module.
500 static int SQLITE_TCLAPI
register_tclvar_module(
501 ClientData clientData
, /* Pointer to sqlite3_enable_XXX function */
502 Tcl_Interp
*interp
, /* The TCL interpreter that invoked this command */
503 int objc
, /* Number of arguments */
504 Tcl_Obj
*CONST objv
[] /* Command arguments */
509 Tcl_WrongNumArgs(interp
, 1, objv
, "DB");
512 if( getDbPointer(interp
, Tcl_GetString(objv
[1]), &db
) ) return TCL_ERROR
;
513 #ifndef SQLITE_OMIT_VIRTUALTABLE
514 sqlite3_create_module(db
, "tclvar", &tclvarModule
, (void*)interp
);
515 rc
= Tcl_Eval(interp
,
516 "proc like {pattern str} {\n"
517 " set p [string map {% * _ ?} $pattern]\n"
518 " string match $p $str\n"
520 "proc tclvar_filter_cmd {eq match glob regexp like} {\n"
523 " if {$pattern=={}} { set pattern $match }\n"
524 " if {$pattern=={}} { set pattern * }\n"
525 " foreach v [uplevel #0 info vars $pattern] {\n"
526 " if {($glob=={} || [string match $glob [uplevel #0 set $v]])\n"
527 " && ($like=={} || [like $like [uplevel #0 set $v]])\n"
528 " && ($regexp=={} || [regexp $regexp [uplevel #0 set $v]])\n"
544 ** Register commands with the TCL interpreter.
546 int Sqlitetesttclvar_Init(Tcl_Interp
*interp
){
547 #ifndef SQLITE_OMIT_VIRTUALTABLE
550 Tcl_ObjCmdProc
*xProc
;
553 { "register_tclvar_module", register_tclvar_module
, 0 },
556 for(i
=0; i
<sizeof(aObjCmd
)/sizeof(aObjCmd
[0]); i
++){
557 Tcl_CreateObjCommand(interp
, aObjCmd
[i
].zName
,
558 aObjCmd
[i
].xProc
, aObjCmd
[i
].clientData
, 0);