xref: /titanic_41/usr/src/lib/libsqlite/src/tclsqlite.c (revision c5c4113dfcabb1eed3d4bdf7609de5170027a794)
1 
2 #pragma ident	"%Z%%M%	%I%	%E% SMI"
3 
4 /*
5 ** 2001 September 15
6 **
7 ** The author disclaims copyright to this source code.  In place of
8 ** a legal notice, here is a blessing:
9 **
10 **    May you do good and not evil.
11 **    May you find forgiveness for yourself and forgive others.
12 **    May you share freely, never taking more than you give.
13 **
14 *************************************************************************
15 ** A TCL Interface to SQLite
16 **
17 ** $Id: tclsqlite.c,v 1.59.2.1 2004/06/19 11:57:40 drh Exp $
18 */
19 #ifndef NO_TCL     /* Omit this whole file if TCL is unavailable */
20 
21 #include "sqliteInt.h"
22 #include "tcl.h"
23 #include <stdlib.h>
24 #include <string.h>
25 #include <assert.h>
26 
27 /*
28 ** If TCL uses UTF-8 and SQLite is configured to use iso8859, then we
29 ** have to do a translation when going between the two.  Set the
30 ** UTF_TRANSLATION_NEEDED macro to indicate that we need to do
31 ** this translation.
32 */
33 #if defined(TCL_UTF_MAX) && !defined(SQLITE_UTF8)
34 # define UTF_TRANSLATION_NEEDED 1
35 #endif
36 
37 /*
38 ** New SQL functions can be created as TCL scripts.  Each such function
39 ** is described by an instance of the following structure.
40 */
41 typedef struct SqlFunc SqlFunc;
42 struct SqlFunc {
43   Tcl_Interp *interp;   /* The TCL interpret to execute the function */
44   char *zScript;        /* The script to be run */
45   SqlFunc *pNext;       /* Next function on the list of them all */
46 };
47 
48 /*
49 ** There is one instance of this structure for each SQLite database
50 ** that has been opened by the SQLite TCL interface.
51 */
52 typedef struct SqliteDb SqliteDb;
53 struct SqliteDb {
54   sqlite *db;           /* The "real" database structure */
55   Tcl_Interp *interp;   /* The interpreter used for this database */
56   char *zBusy;          /* The busy callback routine */
57   char *zCommit;        /* The commit hook callback routine */
58   char *zTrace;         /* The trace callback routine */
59   char *zProgress;      /* The progress callback routine */
60   char *zAuth;          /* The authorization callback routine */
61   SqlFunc *pFunc;       /* List of SQL functions */
62   int rc;               /* Return code of most recent sqlite_exec() */
63 };
64 
65 /*
66 ** An instance of this structure passes information thru the sqlite
67 ** logic from the original TCL command into the callback routine.
68 */
69 typedef struct CallbackData CallbackData;
70 struct CallbackData {
71   Tcl_Interp *interp;       /* The TCL interpreter */
72   char *zArray;             /* The array into which data is written */
73   Tcl_Obj *pCode;           /* The code to execute for each row */
74   int once;                 /* Set for first callback only */
75   int tcl_rc;               /* Return code from TCL script */
76   int nColName;             /* Number of entries in the azColName[] array */
77   char **azColName;         /* Column names translated to UTF-8 */
78 };
79 
80 #ifdef UTF_TRANSLATION_NEEDED
81 /*
82 ** Called for each row of the result.
83 **
84 ** This version is used when TCL expects UTF-8 data but the database
85 ** uses the ISO8859 format.  A translation must occur from ISO8859 into
86 ** UTF-8.
87 */
DbEvalCallback(void * clientData,int nCol,char ** azCol,char ** azN)88 static int DbEvalCallback(
89   void *clientData,      /* An instance of CallbackData */
90   int nCol,              /* Number of columns in the result */
91   char ** azCol,         /* Data for each column */
92   char ** azN            /* Name for each column */
93 ){
94   CallbackData *cbData = (CallbackData*)clientData;
95   int i, rc;
96   Tcl_DString dCol;
97   Tcl_DStringInit(&dCol);
98   if( cbData->azColName==0 ){
99     assert( cbData->once );
100     cbData->once = 0;
101     if( cbData->zArray[0] ){
102       Tcl_SetVar2(cbData->interp, cbData->zArray, "*", "", 0);
103     }
104     cbData->azColName = malloc( nCol*sizeof(char*) );
105     if( cbData->azColName==0 ){ return 1; }
106     cbData->nColName = nCol;
107     for(i=0; i<nCol; i++){
108       Tcl_ExternalToUtfDString(NULL, azN[i], -1, &dCol);
109       cbData->azColName[i] = malloc( Tcl_DStringLength(&dCol) + 1 );
110       if( cbData->azColName[i] ){
111         strcpy(cbData->azColName[i], Tcl_DStringValue(&dCol));
112       }else{
113         return 1;
114       }
115       if( cbData->zArray[0] ){
116         Tcl_SetVar2(cbData->interp, cbData->zArray, "*",
117              Tcl_DStringValue(&dCol), TCL_LIST_ELEMENT|TCL_APPEND_VALUE);
118         if( azN[nCol]!=0 ){
119           Tcl_DString dType;
120           Tcl_DStringInit(&dType);
121           Tcl_DStringAppend(&dType, "typeof:", -1);
122           Tcl_DStringAppend(&dType, Tcl_DStringValue(&dCol), -1);
123           Tcl_DStringFree(&dCol);
124           Tcl_ExternalToUtfDString(NULL, azN[i+nCol], -1, &dCol);
125           Tcl_SetVar2(cbData->interp, cbData->zArray,
126                Tcl_DStringValue(&dType), Tcl_DStringValue(&dCol),
127                TCL_LIST_ELEMENT|TCL_APPEND_VALUE);
128           Tcl_DStringFree(&dType);
129         }
130       }
131 
132       Tcl_DStringFree(&dCol);
133     }
134   }
135   if( azCol!=0 ){
136     if( cbData->zArray[0] ){
137       for(i=0; i<nCol; i++){
138         char *z = azCol[i];
139         if( z==0 ) z = "";
140         Tcl_DStringInit(&dCol);
141         Tcl_ExternalToUtfDString(NULL, z, -1, &dCol);
142         Tcl_SetVar2(cbData->interp, cbData->zArray, cbData->azColName[i],
143               Tcl_DStringValue(&dCol), 0);
144         Tcl_DStringFree(&dCol);
145       }
146     }else{
147       for(i=0; i<nCol; i++){
148         char *z = azCol[i];
149         if( z==0 ) z = "";
150         Tcl_DStringInit(&dCol);
151         Tcl_ExternalToUtfDString(NULL, z, -1, &dCol);
152         Tcl_SetVar(cbData->interp, cbData->azColName[i],
153                    Tcl_DStringValue(&dCol), 0);
154         Tcl_DStringFree(&dCol);
155       }
156     }
157   }
158   rc = Tcl_EvalObj(cbData->interp, cbData->pCode);
159   if( rc==TCL_CONTINUE ) rc = TCL_OK;
160   cbData->tcl_rc = rc;
161   return rc!=TCL_OK;
162 }
163 #endif /* UTF_TRANSLATION_NEEDED */
164 
165 #ifndef UTF_TRANSLATION_NEEDED
166 /*
167 ** Called for each row of the result.
168 **
169 ** This version is used when either of the following is true:
170 **
171 **    (1) This version of TCL uses UTF-8 and the data in the
172 **        SQLite database is already in the UTF-8 format.
173 **
174 **    (2) This version of TCL uses ISO8859 and the data in the
175 **        SQLite database is already in the ISO8859 format.
176 */
DbEvalCallback(void * clientData,int nCol,char ** azCol,char ** azN)177 static int DbEvalCallback(
178   void *clientData,      /* An instance of CallbackData */
179   int nCol,              /* Number of columns in the result */
180   char ** azCol,         /* Data for each column */
181   char ** azN            /* Name for each column */
182 ){
183   CallbackData *cbData = (CallbackData*)clientData;
184   int i, rc;
185   if( azCol==0 || (cbData->once && cbData->zArray[0]) ){
186     Tcl_SetVar2(cbData->interp, cbData->zArray, "*", "", 0);
187     for(i=0; i<nCol; i++){
188       Tcl_SetVar2(cbData->interp, cbData->zArray, "*", azN[i],
189          TCL_LIST_ELEMENT|TCL_APPEND_VALUE);
190       if( azN[nCol] ){
191         char *z = sqlite_mprintf("typeof:%s", azN[i]);
192         Tcl_SetVar2(cbData->interp, cbData->zArray, z, azN[i+nCol],
193            TCL_LIST_ELEMENT|TCL_APPEND_VALUE);
194         sqlite_freemem(z);
195       }
196     }
197     cbData->once = 0;
198   }
199   if( azCol!=0 ){
200     if( cbData->zArray[0] ){
201       for(i=0; i<nCol; i++){
202         char *z = azCol[i];
203         if( z==0 ) z = "";
204         Tcl_SetVar2(cbData->interp, cbData->zArray, azN[i], z, 0);
205       }
206     }else{
207       for(i=0; i<nCol; i++){
208         char *z = azCol[i];
209         if( z==0 ) z = "";
210         Tcl_SetVar(cbData->interp, azN[i], z, 0);
211       }
212     }
213   }
214   rc = Tcl_EvalObj(cbData->interp, cbData->pCode);
215   if( rc==TCL_CONTINUE ) rc = TCL_OK;
216   cbData->tcl_rc = rc;
217   return rc!=TCL_OK;
218 }
219 #endif
220 
221 /*
222 ** This is an alternative callback for database queries.  Instead
223 ** of invoking a TCL script to handle the result, this callback just
224 ** appends each column of the result to a list.  After the query
225 ** is complete, the list is returned.
226 */
DbEvalCallback2(void * clientData,int nCol,char ** azCol,char ** azN)227 static int DbEvalCallback2(
228   void *clientData,      /* An instance of CallbackData */
229   int nCol,              /* Number of columns in the result */
230   char ** azCol,         /* Data for each column */
231   char ** azN            /* Name for each column */
232 ){
233   Tcl_Obj *pList = (Tcl_Obj*)clientData;
234   int i;
235   if( azCol==0 ) return 0;
236   for(i=0; i<nCol; i++){
237     Tcl_Obj *pElem;
238     if( azCol[i] && *azCol[i] ){
239 #ifdef UTF_TRANSLATION_NEEDED
240       Tcl_DString dCol;
241       Tcl_DStringInit(&dCol);
242       Tcl_ExternalToUtfDString(NULL, azCol[i], -1, &dCol);
243       pElem = Tcl_NewStringObj(Tcl_DStringValue(&dCol), -1);
244       Tcl_DStringFree(&dCol);
245 #else
246       pElem = Tcl_NewStringObj(azCol[i], -1);
247 #endif
248     }else{
249       pElem = Tcl_NewObj();
250     }
251     Tcl_ListObjAppendElement(0, pList, pElem);
252   }
253   return 0;
254 }
255 
256 /*
257 ** This is a second alternative callback for database queries.  A the
258 ** first column of the first row of the result is made the TCL result.
259 */
DbEvalCallback3(void * clientData,int nCol,char ** azCol,char ** azN)260 static int DbEvalCallback3(
261   void *clientData,      /* An instance of CallbackData */
262   int nCol,              /* Number of columns in the result */
263   char ** azCol,         /* Data for each column */
264   char ** azN            /* Name for each column */
265 ){
266   Tcl_Interp *interp = (Tcl_Interp*)clientData;
267   Tcl_Obj *pElem;
268   if( azCol==0 ) return 1;
269   if( nCol==0 ) return 1;
270 #ifdef UTF_TRANSLATION_NEEDED
271   {
272     Tcl_DString dCol;
273     Tcl_DStringInit(&dCol);
274     Tcl_ExternalToUtfDString(NULL, azCol[0], -1, &dCol);
275     pElem = Tcl_NewStringObj(Tcl_DStringValue(&dCol), -1);
276     Tcl_DStringFree(&dCol);
277   }
278 #else
279   pElem = Tcl_NewStringObj(azCol[0], -1);
280 #endif
281   Tcl_SetObjResult(interp, pElem);
282   return 1;
283 }
284 
285 /*
286 ** Called when the command is deleted.
287 */
DbDeleteCmd(void * db)288 static void DbDeleteCmd(void *db){
289   SqliteDb *pDb = (SqliteDb*)db;
290   sqlite_close(pDb->db);
291   while( pDb->pFunc ){
292     SqlFunc *pFunc = pDb->pFunc;
293     pDb->pFunc = pFunc->pNext;
294     Tcl_Free((char*)pFunc);
295   }
296   if( pDb->zBusy ){
297     Tcl_Free(pDb->zBusy);
298   }
299   if( pDb->zTrace ){
300     Tcl_Free(pDb->zTrace);
301   }
302   if( pDb->zAuth ){
303     Tcl_Free(pDb->zAuth);
304   }
305   Tcl_Free((char*)pDb);
306 }
307 
308 /*
309 ** This routine is called when a database file is locked while trying
310 ** to execute SQL.
311 */
DbBusyHandler(void * cd,const char * zTable,int nTries)312 static int DbBusyHandler(void *cd, const char *zTable, int nTries){
313   SqliteDb *pDb = (SqliteDb*)cd;
314   int rc;
315   char zVal[30];
316   char *zCmd;
317   Tcl_DString cmd;
318 
319   Tcl_DStringInit(&cmd);
320   Tcl_DStringAppend(&cmd, pDb->zBusy, -1);
321   Tcl_DStringAppendElement(&cmd, zTable);
322   sprintf(zVal, " %d", nTries);
323   Tcl_DStringAppend(&cmd, zVal, -1);
324   zCmd = Tcl_DStringValue(&cmd);
325   rc = Tcl_Eval(pDb->interp, zCmd);
326   Tcl_DStringFree(&cmd);
327   if( rc!=TCL_OK || atoi(Tcl_GetStringResult(pDb->interp)) ){
328     return 0;
329   }
330   return 1;
331 }
332 
333 /*
334 ** This routine is invoked as the 'progress callback' for the database.
335 */
DbProgressHandler(void * cd)336 static int DbProgressHandler(void *cd){
337   SqliteDb *pDb = (SqliteDb*)cd;
338   int rc;
339 
340   assert( pDb->zProgress );
341   rc = Tcl_Eval(pDb->interp, pDb->zProgress);
342   if( rc!=TCL_OK || atoi(Tcl_GetStringResult(pDb->interp)) ){
343     return 1;
344   }
345   return 0;
346 }
347 
348 /*
349 ** This routine is called by the SQLite trace handler whenever a new
350 ** block of SQL is executed.  The TCL script in pDb->zTrace is executed.
351 */
DbTraceHandler(void * cd,const char * zSql)352 static void DbTraceHandler(void *cd, const char *zSql){
353   SqliteDb *pDb = (SqliteDb*)cd;
354   Tcl_DString str;
355 
356   Tcl_DStringInit(&str);
357   Tcl_DStringAppend(&str, pDb->zTrace, -1);
358   Tcl_DStringAppendElement(&str, zSql);
359   Tcl_Eval(pDb->interp, Tcl_DStringValue(&str));
360   Tcl_DStringFree(&str);
361   Tcl_ResetResult(pDb->interp);
362 }
363 
364 /*
365 ** This routine is called when a transaction is committed.  The
366 ** TCL script in pDb->zCommit is executed.  If it returns non-zero or
367 ** if it throws an exception, the transaction is rolled back instead
368 ** of being committed.
369 */
DbCommitHandler(void * cd)370 static int DbCommitHandler(void *cd){
371   SqliteDb *pDb = (SqliteDb*)cd;
372   int rc;
373 
374   rc = Tcl_Eval(pDb->interp, pDb->zCommit);
375   if( rc!=TCL_OK || atoi(Tcl_GetStringResult(pDb->interp)) ){
376     return 1;
377   }
378   return 0;
379 }
380 
381 /*
382 ** This routine is called to evaluate an SQL function implemented
383 ** using TCL script.
384 */
tclSqlFunc(sqlite_func * context,int argc,const char ** argv)385 static void tclSqlFunc(sqlite_func *context, int argc, const char **argv){
386   SqlFunc *p = sqlite_user_data(context);
387   Tcl_DString cmd;
388   int i;
389   int rc;
390 
391   Tcl_DStringInit(&cmd);
392   Tcl_DStringAppend(&cmd, p->zScript, -1);
393   for(i=0; i<argc; i++){
394     Tcl_DStringAppendElement(&cmd, argv[i] ? argv[i] : "");
395   }
396   rc = Tcl_Eval(p->interp, Tcl_DStringValue(&cmd));
397   if( rc ){
398     sqlite_set_result_error(context, Tcl_GetStringResult(p->interp), -1);
399   }else{
400     sqlite_set_result_string(context, Tcl_GetStringResult(p->interp), -1);
401   }
402 }
403 #ifndef SQLITE_OMIT_AUTHORIZATION
404 /*
405 ** This is the authentication function.  It appends the authentication
406 ** type code and the two arguments to zCmd[] then invokes the result
407 ** on the interpreter.  The reply is examined to determine if the
408 ** authentication fails or succeeds.
409 */
auth_callback(void * pArg,int code,const char * zArg1,const char * zArg2,const char * zArg3,const char * zArg4)410 static int auth_callback(
411   void *pArg,
412   int code,
413   const char *zArg1,
414   const char *zArg2,
415   const char *zArg3,
416   const char *zArg4
417 ){
418   char *zCode;
419   Tcl_DString str;
420   int rc;
421   const char *zReply;
422   SqliteDb *pDb = (SqliteDb*)pArg;
423 
424   switch( code ){
425     case SQLITE_COPY              : zCode="SQLITE_COPY"; break;
426     case SQLITE_CREATE_INDEX      : zCode="SQLITE_CREATE_INDEX"; break;
427     case SQLITE_CREATE_TABLE      : zCode="SQLITE_CREATE_TABLE"; break;
428     case SQLITE_CREATE_TEMP_INDEX : zCode="SQLITE_CREATE_TEMP_INDEX"; break;
429     case SQLITE_CREATE_TEMP_TABLE : zCode="SQLITE_CREATE_TEMP_TABLE"; break;
430     case SQLITE_CREATE_TEMP_TRIGGER: zCode="SQLITE_CREATE_TEMP_TRIGGER"; break;
431     case SQLITE_CREATE_TEMP_VIEW  : zCode="SQLITE_CREATE_TEMP_VIEW"; break;
432     case SQLITE_CREATE_TRIGGER    : zCode="SQLITE_CREATE_TRIGGER"; break;
433     case SQLITE_CREATE_VIEW       : zCode="SQLITE_CREATE_VIEW"; break;
434     case SQLITE_DELETE            : zCode="SQLITE_DELETE"; break;
435     case SQLITE_DROP_INDEX        : zCode="SQLITE_DROP_INDEX"; break;
436     case SQLITE_DROP_TABLE        : zCode="SQLITE_DROP_TABLE"; break;
437     case SQLITE_DROP_TEMP_INDEX   : zCode="SQLITE_DROP_TEMP_INDEX"; break;
438     case SQLITE_DROP_TEMP_TABLE   : zCode="SQLITE_DROP_TEMP_TABLE"; break;
439     case SQLITE_DROP_TEMP_TRIGGER : zCode="SQLITE_DROP_TEMP_TRIGGER"; break;
440     case SQLITE_DROP_TEMP_VIEW    : zCode="SQLITE_DROP_TEMP_VIEW"; break;
441     case SQLITE_DROP_TRIGGER      : zCode="SQLITE_DROP_TRIGGER"; break;
442     case SQLITE_DROP_VIEW         : zCode="SQLITE_DROP_VIEW"; break;
443     case SQLITE_INSERT            : zCode="SQLITE_INSERT"; break;
444     case SQLITE_PRAGMA            : zCode="SQLITE_PRAGMA"; break;
445     case SQLITE_READ              : zCode="SQLITE_READ"; break;
446     case SQLITE_SELECT            : zCode="SQLITE_SELECT"; break;
447     case SQLITE_TRANSACTION       : zCode="SQLITE_TRANSACTION"; break;
448     case SQLITE_UPDATE            : zCode="SQLITE_UPDATE"; break;
449     case SQLITE_ATTACH            : zCode="SQLITE_ATTACH"; break;
450     case SQLITE_DETACH            : zCode="SQLITE_DETACH"; break;
451     default                       : zCode="????"; break;
452   }
453   Tcl_DStringInit(&str);
454   Tcl_DStringAppend(&str, pDb->zAuth, -1);
455   Tcl_DStringAppendElement(&str, zCode);
456   Tcl_DStringAppendElement(&str, zArg1 ? zArg1 : "");
457   Tcl_DStringAppendElement(&str, zArg2 ? zArg2 : "");
458   Tcl_DStringAppendElement(&str, zArg3 ? zArg3 : "");
459   Tcl_DStringAppendElement(&str, zArg4 ? zArg4 : "");
460   rc = Tcl_GlobalEval(pDb->interp, Tcl_DStringValue(&str));
461   Tcl_DStringFree(&str);
462   zReply = Tcl_GetStringResult(pDb->interp);
463   if( strcmp(zReply,"SQLITE_OK")==0 ){
464     rc = SQLITE_OK;
465   }else if( strcmp(zReply,"SQLITE_DENY")==0 ){
466     rc = SQLITE_DENY;
467   }else if( strcmp(zReply,"SQLITE_IGNORE")==0 ){
468     rc = SQLITE_IGNORE;
469   }else{
470     rc = 999;
471   }
472   return rc;
473 }
474 #endif /* SQLITE_OMIT_AUTHORIZATION */
475 
476 /*
477 ** The "sqlite" command below creates a new Tcl command for each
478 ** connection it opens to an SQLite database.  This routine is invoked
479 ** whenever one of those connection-specific commands is executed
480 ** in Tcl.  For example, if you run Tcl code like this:
481 **
482 **       sqlite db1  "my_database"
483 **       db1 close
484 **
485 ** The first command opens a connection to the "my_database" database
486 ** and calls that connection "db1".  The second command causes this
487 ** subroutine to be invoked.
488 */
DbObjCmd(void * cd,Tcl_Interp * interp,int objc,Tcl_Obj * const * objv)489 static int DbObjCmd(void *cd, Tcl_Interp *interp, int objc,Tcl_Obj *const*objv){
490   SqliteDb *pDb = (SqliteDb*)cd;
491   int choice;
492   int rc = TCL_OK;
493   static const char *DB_strs[] = {
494     "authorizer",         "busy",                   "changes",
495     "close",              "commit_hook",            "complete",
496     "errorcode",          "eval",                   "function",
497     "last_insert_rowid",  "last_statement_changes", "onecolumn",
498     "progress",           "rekey",                  "timeout",
499     "trace",
500     0
501   };
502   enum DB_enum {
503     DB_AUTHORIZER,        DB_BUSY,                   DB_CHANGES,
504     DB_CLOSE,             DB_COMMIT_HOOK,            DB_COMPLETE,
505     DB_ERRORCODE,         DB_EVAL,                   DB_FUNCTION,
506     DB_LAST_INSERT_ROWID, DB_LAST_STATEMENT_CHANGES, DB_ONECOLUMN,
507     DB_PROGRESS,          DB_REKEY,                  DB_TIMEOUT,
508     DB_TRACE
509   };
510 
511   if( objc<2 ){
512     Tcl_WrongNumArgs(interp, 1, objv, "SUBCOMMAND ...");
513     return TCL_ERROR;
514   }
515   if( Tcl_GetIndexFromObj(interp, objv[1], DB_strs, "option", 0, &choice) ){
516     return TCL_ERROR;
517   }
518 
519   switch( (enum DB_enum)choice ){
520 
521   /*    $db authorizer ?CALLBACK?
522   **
523   ** Invoke the given callback to authorize each SQL operation as it is
524   ** compiled.  5 arguments are appended to the callback before it is
525   ** invoked:
526   **
527   **   (1) The authorization type (ex: SQLITE_CREATE_TABLE, SQLITE_INSERT, ...)
528   **   (2) First descriptive name (depends on authorization type)
529   **   (3) Second descriptive name
530   **   (4) Name of the database (ex: "main", "temp")
531   **   (5) Name of trigger that is doing the access
532   **
533   ** The callback should return on of the following strings: SQLITE_OK,
534   ** SQLITE_IGNORE, or SQLITE_DENY.  Any other return value is an error.
535   **
536   ** If this method is invoked with no arguments, the current authorization
537   ** callback string is returned.
538   */
539   case DB_AUTHORIZER: {
540     if( objc>3 ){
541       Tcl_WrongNumArgs(interp, 2, objv, "?CALLBACK?");
542     }else if( objc==2 ){
543       if( pDb->zAuth ){
544         Tcl_AppendResult(interp, pDb->zAuth, 0);
545       }
546     }else{
547       char *zAuth;
548       int len;
549       if( pDb->zAuth ){
550         Tcl_Free(pDb->zAuth);
551       }
552       zAuth = Tcl_GetStringFromObj(objv[2], &len);
553       if( zAuth && len>0 ){
554         pDb->zAuth = Tcl_Alloc( len + 1 );
555         strcpy(pDb->zAuth, zAuth);
556       }else{
557         pDb->zAuth = 0;
558       }
559 #ifndef SQLITE_OMIT_AUTHORIZATION
560       if( pDb->zAuth ){
561         pDb->interp = interp;
562         sqlite_set_authorizer(pDb->db, auth_callback, pDb);
563       }else{
564         sqlite_set_authorizer(pDb->db, 0, 0);
565       }
566 #endif
567     }
568     break;
569   }
570 
571   /*    $db busy ?CALLBACK?
572   **
573   ** Invoke the given callback if an SQL statement attempts to open
574   ** a locked database file.
575   */
576   case DB_BUSY: {
577     if( objc>3 ){
578       Tcl_WrongNumArgs(interp, 2, objv, "CALLBACK");
579       return TCL_ERROR;
580     }else if( objc==2 ){
581       if( pDb->zBusy ){
582         Tcl_AppendResult(interp, pDb->zBusy, 0);
583       }
584     }else{
585       char *zBusy;
586       int len;
587       if( pDb->zBusy ){
588         Tcl_Free(pDb->zBusy);
589       }
590       zBusy = Tcl_GetStringFromObj(objv[2], &len);
591       if( zBusy && len>0 ){
592         pDb->zBusy = Tcl_Alloc( len + 1 );
593         strcpy(pDb->zBusy, zBusy);
594       }else{
595         pDb->zBusy = 0;
596       }
597       if( pDb->zBusy ){
598         pDb->interp = interp;
599         sqlite_busy_handler(pDb->db, DbBusyHandler, pDb);
600       }else{
601         sqlite_busy_handler(pDb->db, 0, 0);
602       }
603     }
604     break;
605   }
606 
607   /*    $db progress ?N CALLBACK?
608   **
609   ** Invoke the given callback every N virtual machine opcodes while executing
610   ** queries.
611   */
612   case DB_PROGRESS: {
613     if( objc==2 ){
614       if( pDb->zProgress ){
615         Tcl_AppendResult(interp, pDb->zProgress, 0);
616       }
617     }else if( objc==4 ){
618       char *zProgress;
619       int len;
620       int N;
621       if( TCL_OK!=Tcl_GetIntFromObj(interp, objv[2], &N) ){
622 	return TCL_ERROR;
623       };
624       if( pDb->zProgress ){
625         Tcl_Free(pDb->zProgress);
626       }
627       zProgress = Tcl_GetStringFromObj(objv[3], &len);
628       if( zProgress && len>0 ){
629         pDb->zProgress = Tcl_Alloc( len + 1 );
630         strcpy(pDb->zProgress, zProgress);
631       }else{
632         pDb->zProgress = 0;
633       }
634 #ifndef SQLITE_OMIT_PROGRESS_CALLBACK
635       if( pDb->zProgress ){
636         pDb->interp = interp;
637         sqlite_progress_handler(pDb->db, N, DbProgressHandler, pDb);
638       }else{
639         sqlite_progress_handler(pDb->db, 0, 0, 0);
640       }
641 #endif
642     }else{
643       Tcl_WrongNumArgs(interp, 2, objv, "N CALLBACK");
644       return TCL_ERROR;
645     }
646     break;
647   }
648 
649   /*
650   **     $db changes
651   **
652   ** Return the number of rows that were modified, inserted, or deleted by
653   ** the most recent "eval".
654   */
655   case DB_CHANGES: {
656     Tcl_Obj *pResult;
657     int nChange;
658     if( objc!=2 ){
659       Tcl_WrongNumArgs(interp, 2, objv, "");
660       return TCL_ERROR;
661     }
662     nChange = sqlite_changes(pDb->db);
663     pResult = Tcl_GetObjResult(interp);
664     Tcl_SetIntObj(pResult, nChange);
665     break;
666   }
667 
668   /*
669   **     $db last_statement_changes
670   **
671   ** Return the number of rows that were modified, inserted, or deleted by
672   ** the last statment to complete execution (excluding changes due to
673   ** triggers)
674   */
675   case DB_LAST_STATEMENT_CHANGES: {
676     Tcl_Obj *pResult;
677     int lsChange;
678     if( objc!=2 ){
679       Tcl_WrongNumArgs(interp, 2, objv, "");
680       return TCL_ERROR;
681     }
682     lsChange = sqlite_last_statement_changes(pDb->db);
683     pResult = Tcl_GetObjResult(interp);
684     Tcl_SetIntObj(pResult, lsChange);
685     break;
686   }
687 
688   /*    $db close
689   **
690   ** Shutdown the database
691   */
692   case DB_CLOSE: {
693     Tcl_DeleteCommand(interp, Tcl_GetStringFromObj(objv[0], 0));
694     break;
695   }
696 
697   /*    $db commit_hook ?CALLBACK?
698   **
699   ** Invoke the given callback just before committing every SQL transaction.
700   ** If the callback throws an exception or returns non-zero, then the
701   ** transaction is aborted.  If CALLBACK is an empty string, the callback
702   ** is disabled.
703   */
704   case DB_COMMIT_HOOK: {
705     if( objc>3 ){
706       Tcl_WrongNumArgs(interp, 2, objv, "?CALLBACK?");
707     }else if( objc==2 ){
708       if( pDb->zCommit ){
709         Tcl_AppendResult(interp, pDb->zCommit, 0);
710       }
711     }else{
712       char *zCommit;
713       int len;
714       if( pDb->zCommit ){
715         Tcl_Free(pDb->zCommit);
716       }
717       zCommit = Tcl_GetStringFromObj(objv[2], &len);
718       if( zCommit && len>0 ){
719         pDb->zCommit = Tcl_Alloc( len + 1 );
720         strcpy(pDb->zCommit, zCommit);
721       }else{
722         pDb->zCommit = 0;
723       }
724       if( pDb->zCommit ){
725         pDb->interp = interp;
726         sqlite_commit_hook(pDb->db, DbCommitHandler, pDb);
727       }else{
728         sqlite_commit_hook(pDb->db, 0, 0);
729       }
730     }
731     break;
732   }
733 
734   /*    $db complete SQL
735   **
736   ** Return TRUE if SQL is a complete SQL statement.  Return FALSE if
737   ** additional lines of input are needed.  This is similar to the
738   ** built-in "info complete" command of Tcl.
739   */
740   case DB_COMPLETE: {
741     Tcl_Obj *pResult;
742     int isComplete;
743     if( objc!=3 ){
744       Tcl_WrongNumArgs(interp, 2, objv, "SQL");
745       return TCL_ERROR;
746     }
747     isComplete = sqlite_complete( Tcl_GetStringFromObj(objv[2], 0) );
748     pResult = Tcl_GetObjResult(interp);
749     Tcl_SetBooleanObj(pResult, isComplete);
750     break;
751   }
752 
753   /*
754   **    $db errorcode
755   **
756   ** Return the numeric error code that was returned by the most recent
757   ** call to sqlite_exec().
758   */
759   case DB_ERRORCODE: {
760     Tcl_SetObjResult(interp, Tcl_NewIntObj(pDb->rc));
761     break;
762   }
763 
764   /*
765   **    $db eval $sql ?array {  ...code... }?
766   **
767   ** The SQL statement in $sql is evaluated.  For each row, the values are
768   ** placed in elements of the array named "array" and ...code... is executed.
769   ** If "array" and "code" are omitted, then no callback is every invoked.
770   ** If "array" is an empty string, then the values are placed in variables
771   ** that have the same name as the fields extracted by the query.
772   */
773   case DB_EVAL: {
774     CallbackData cbData;
775     char *zErrMsg;
776     char *zSql;
777 #ifdef UTF_TRANSLATION_NEEDED
778     Tcl_DString dSql;
779     int i;
780 #endif
781 
782     if( objc!=5 && objc!=3 ){
783       Tcl_WrongNumArgs(interp, 2, objv, "SQL ?ARRAY-NAME CODE?");
784       return TCL_ERROR;
785     }
786     pDb->interp = interp;
787     zSql = Tcl_GetStringFromObj(objv[2], 0);
788 #ifdef UTF_TRANSLATION_NEEDED
789     Tcl_DStringInit(&dSql);
790     Tcl_UtfToExternalDString(NULL, zSql, -1, &dSql);
791     zSql = Tcl_DStringValue(&dSql);
792 #endif
793     Tcl_IncrRefCount(objv[2]);
794     if( objc==5 ){
795       cbData.interp = interp;
796       cbData.once = 1;
797       cbData.zArray = Tcl_GetStringFromObj(objv[3], 0);
798       cbData.pCode = objv[4];
799       cbData.tcl_rc = TCL_OK;
800       cbData.nColName = 0;
801       cbData.azColName = 0;
802       zErrMsg = 0;
803       Tcl_IncrRefCount(objv[3]);
804       Tcl_IncrRefCount(objv[4]);
805       rc = sqlite_exec(pDb->db, zSql, DbEvalCallback, &cbData, &zErrMsg);
806       Tcl_DecrRefCount(objv[4]);
807       Tcl_DecrRefCount(objv[3]);
808       if( cbData.tcl_rc==TCL_BREAK ){ cbData.tcl_rc = TCL_OK; }
809     }else{
810       Tcl_Obj *pList = Tcl_NewObj();
811       cbData.tcl_rc = TCL_OK;
812       rc = sqlite_exec(pDb->db, zSql, DbEvalCallback2, pList, &zErrMsg);
813       Tcl_SetObjResult(interp, pList);
814     }
815     pDb->rc = rc;
816     if( rc==SQLITE_ABORT ){
817       if( zErrMsg ) free(zErrMsg);
818       rc = cbData.tcl_rc;
819     }else if( zErrMsg ){
820       Tcl_SetResult(interp, zErrMsg, TCL_VOLATILE);
821       free(zErrMsg);
822       rc = TCL_ERROR;
823     }else if( rc!=SQLITE_OK ){
824       Tcl_AppendResult(interp, sqlite_error_string(rc), 0);
825       rc = TCL_ERROR;
826     }else{
827     }
828     Tcl_DecrRefCount(objv[2]);
829 #ifdef UTF_TRANSLATION_NEEDED
830     Tcl_DStringFree(&dSql);
831     if( objc==5 && cbData.azColName ){
832       for(i=0; i<cbData.nColName; i++){
833         if( cbData.azColName[i] ) free(cbData.azColName[i]);
834       }
835       free(cbData.azColName);
836       cbData.azColName = 0;
837     }
838 #endif
839     return rc;
840   }
841 
842   /*
843   **     $db function NAME SCRIPT
844   **
845   ** Create a new SQL function called NAME.  Whenever that function is
846   ** called, invoke SCRIPT to evaluate the function.
847   */
848   case DB_FUNCTION: {
849     SqlFunc *pFunc;
850     char *zName;
851     char *zScript;
852     int nScript;
853     if( objc!=4 ){
854       Tcl_WrongNumArgs(interp, 2, objv, "NAME SCRIPT");
855       return TCL_ERROR;
856     }
857     zName = Tcl_GetStringFromObj(objv[2], 0);
858     zScript = Tcl_GetStringFromObj(objv[3], &nScript);
859     pFunc = (SqlFunc*)Tcl_Alloc( sizeof(*pFunc) + nScript + 1 );
860     if( pFunc==0 ) return TCL_ERROR;
861     pFunc->interp = interp;
862     pFunc->pNext = pDb->pFunc;
863     pFunc->zScript = (char*)&pFunc[1];
864     strcpy(pFunc->zScript, zScript);
865     sqlite_create_function(pDb->db, zName, -1, tclSqlFunc, pFunc);
866     sqlite_function_type(pDb->db, zName, SQLITE_NUMERIC);
867     break;
868   }
869 
870   /*
871   **     $db last_insert_rowid
872   **
873   ** Return an integer which is the ROWID for the most recent insert.
874   */
875   case DB_LAST_INSERT_ROWID: {
876     Tcl_Obj *pResult;
877     int rowid;
878     if( objc!=2 ){
879       Tcl_WrongNumArgs(interp, 2, objv, "");
880       return TCL_ERROR;
881     }
882     rowid = sqlite_last_insert_rowid(pDb->db);
883     pResult = Tcl_GetObjResult(interp);
884     Tcl_SetIntObj(pResult, rowid);
885     break;
886   }
887 
888   /*
889   **     $db onecolumn SQL
890   **
891   ** Return a single column from a single row of the given SQL query.
892   */
893   case DB_ONECOLUMN: {
894     char *zSql;
895     char *zErrMsg = 0;
896     if( objc!=3 ){
897       Tcl_WrongNumArgs(interp, 2, objv, "SQL");
898       return TCL_ERROR;
899     }
900     zSql = Tcl_GetStringFromObj(objv[2], 0);
901     rc = sqlite_exec(pDb->db, zSql, DbEvalCallback3, interp, &zErrMsg);
902     if( rc==SQLITE_ABORT ){
903       rc = SQLITE_OK;
904     }else if( zErrMsg ){
905       Tcl_SetResult(interp, zErrMsg, TCL_VOLATILE);
906       free(zErrMsg);
907       rc = TCL_ERROR;
908     }else if( rc!=SQLITE_OK ){
909       Tcl_AppendResult(interp, sqlite_error_string(rc), 0);
910       rc = TCL_ERROR;
911     }
912     break;
913   }
914 
915   /*
916   **     $db rekey KEY
917   **
918   ** Change the encryption key on the currently open database.
919   */
920   case DB_REKEY: {
921     int nKey;
922     void *pKey;
923     if( objc!=3 ){
924       Tcl_WrongNumArgs(interp, 2, objv, "KEY");
925       return TCL_ERROR;
926     }
927     pKey = Tcl_GetByteArrayFromObj(objv[2], &nKey);
928 #ifdef SQLITE_HAS_CODEC
929     rc = sqlite_rekey(pDb->db, pKey, nKey);
930     if( rc ){
931       Tcl_AppendResult(interp, sqlite_error_string(rc), 0);
932       rc = TCL_ERROR;
933     }
934 #endif
935     break;
936   }
937 
938   /*
939   **     $db timeout MILLESECONDS
940   **
941   ** Delay for the number of milliseconds specified when a file is locked.
942   */
943   case DB_TIMEOUT: {
944     int ms;
945     if( objc!=3 ){
946       Tcl_WrongNumArgs(interp, 2, objv, "MILLISECONDS");
947       return TCL_ERROR;
948     }
949     if( Tcl_GetIntFromObj(interp, objv[2], &ms) ) return TCL_ERROR;
950     sqlite_busy_timeout(pDb->db, ms);
951     break;
952   }
953 
954   /*    $db trace ?CALLBACK?
955   **
956   ** Make arrangements to invoke the CALLBACK routine for each SQL statement
957   ** that is executed.  The text of the SQL is appended to CALLBACK before
958   ** it is executed.
959   */
960   case DB_TRACE: {
961     if( objc>3 ){
962       Tcl_WrongNumArgs(interp, 2, objv, "?CALLBACK?");
963     }else if( objc==2 ){
964       if( pDb->zTrace ){
965         Tcl_AppendResult(interp, pDb->zTrace, 0);
966       }
967     }else{
968       char *zTrace;
969       int len;
970       if( pDb->zTrace ){
971         Tcl_Free(pDb->zTrace);
972       }
973       zTrace = Tcl_GetStringFromObj(objv[2], &len);
974       if( zTrace && len>0 ){
975         pDb->zTrace = Tcl_Alloc( len + 1 );
976         strcpy(pDb->zTrace, zTrace);
977       }else{
978         pDb->zTrace = 0;
979       }
980       if( pDb->zTrace ){
981         pDb->interp = interp;
982         sqlite_trace(pDb->db, DbTraceHandler, pDb);
983       }else{
984         sqlite_trace(pDb->db, 0, 0);
985       }
986     }
987     break;
988   }
989 
990   } /* End of the SWITCH statement */
991   return rc;
992 }
993 
994 /*
995 **   sqlite DBNAME FILENAME ?MODE? ?-key KEY?
996 **
997 ** This is the main Tcl command.  When the "sqlite" Tcl command is
998 ** invoked, this routine runs to process that command.
999 **
1000 ** The first argument, DBNAME, is an arbitrary name for a new
1001 ** database connection.  This command creates a new command named
1002 ** DBNAME that is used to control that connection.  The database
1003 ** connection is deleted when the DBNAME command is deleted.
1004 **
1005 ** The second argument is the name of the directory that contains
1006 ** the sqlite database that is to be accessed.
1007 **
1008 ** For testing purposes, we also support the following:
1009 **
1010 **  sqlite -encoding
1011 **
1012 **       Return the encoding used by LIKE and GLOB operators.  Choices
1013 **       are UTF-8 and iso8859.
1014 **
1015 **  sqlite -version
1016 **
1017 **       Return the version number of the SQLite library.
1018 **
1019 **  sqlite -tcl-uses-utf
1020 **
1021 **       Return "1" if compiled with a Tcl uses UTF-8.  Return "0" if
1022 **       not.  Used by tests to make sure the library was compiled
1023 **       correctly.
1024 */
DbMain(void * cd,Tcl_Interp * interp,int objc,Tcl_Obj * const * objv)1025 static int DbMain(void *cd, Tcl_Interp *interp, int objc,Tcl_Obj *const*objv){
1026   int mode;
1027   SqliteDb *p;
1028   void *pKey = 0;
1029   int nKey = 0;
1030   const char *zArg;
1031   char *zErrMsg;
1032   const char *zFile;
1033   char zBuf[80];
1034   if( objc==2 ){
1035     zArg = Tcl_GetStringFromObj(objv[1], 0);
1036     if( strcmp(zArg,"-encoding")==0 ){
1037       Tcl_AppendResult(interp,sqlite_encoding,0);
1038       return TCL_OK;
1039     }
1040     if( strcmp(zArg,"-version")==0 ){
1041       Tcl_AppendResult(interp,sqlite_version,0);
1042       return TCL_OK;
1043     }
1044     if( strcmp(zArg,"-has-codec")==0 ){
1045 #ifdef SQLITE_HAS_CODEC
1046       Tcl_AppendResult(interp,"1",0);
1047 #else
1048       Tcl_AppendResult(interp,"0",0);
1049 #endif
1050       return TCL_OK;
1051     }
1052     if( strcmp(zArg,"-tcl-uses-utf")==0 ){
1053 #ifdef TCL_UTF_MAX
1054       Tcl_AppendResult(interp,"1",0);
1055 #else
1056       Tcl_AppendResult(interp,"0",0);
1057 #endif
1058       return TCL_OK;
1059     }
1060   }
1061   if( objc==5 || objc==6 ){
1062     zArg = Tcl_GetStringFromObj(objv[objc-2], 0);
1063     if( strcmp(zArg,"-key")==0 ){
1064       pKey = Tcl_GetByteArrayFromObj(objv[objc-1], &nKey);
1065       objc -= 2;
1066     }
1067   }
1068   if( objc!=3 && objc!=4 ){
1069     Tcl_WrongNumArgs(interp, 1, objv,
1070 #ifdef SQLITE_HAS_CODEC
1071       "HANDLE FILENAME ?-key CODEC-KEY?"
1072 #else
1073       "HANDLE FILENAME ?MODE?"
1074 #endif
1075     );
1076     return TCL_ERROR;
1077   }
1078   if( objc==3 ){
1079     mode = 0666;
1080   }else if( Tcl_GetIntFromObj(interp, objv[3], &mode)!=TCL_OK ){
1081     return TCL_ERROR;
1082   }
1083   zErrMsg = 0;
1084   p = (SqliteDb*)Tcl_Alloc( sizeof(*p) );
1085   if( p==0 ){
1086     Tcl_SetResult(interp, "malloc failed", TCL_STATIC);
1087     return TCL_ERROR;
1088   }
1089   memset(p, 0, sizeof(*p));
1090   zFile = Tcl_GetStringFromObj(objv[2], 0);
1091 #ifdef SQLITE_HAS_CODEC
1092   p->db = sqlite_open_encrypted(zFile, pKey, nKey, 0, &zErrMsg);
1093 #else
1094   p->db = sqlite_open(zFile, mode, &zErrMsg);
1095 #endif
1096   if( p->db==0 ){
1097     Tcl_SetResult(interp, zErrMsg, TCL_VOLATILE);
1098     Tcl_Free((char*)p);
1099     free(zErrMsg);
1100     return TCL_ERROR;
1101   }
1102   zArg = Tcl_GetStringFromObj(objv[1], 0);
1103   Tcl_CreateObjCommand(interp, zArg, DbObjCmd, (char*)p, DbDeleteCmd);
1104 
1105   /* The return value is the value of the sqlite* pointer
1106   */
1107   sprintf(zBuf, "%p", p->db);
1108   if( strncmp(zBuf,"0x",2) ){
1109     sprintf(zBuf, "0x%p", p->db);
1110   }
1111   Tcl_AppendResult(interp, zBuf, 0);
1112 
1113   /* If compiled with SQLITE_TEST turned on, then register the "md5sum"
1114   ** SQL function.
1115   */
1116 #ifdef SQLITE_TEST
1117   {
1118     extern void Md5_Register(sqlite*);
1119     Md5_Register(p->db);
1120    }
1121 #endif
1122   return TCL_OK;
1123 }
1124 
1125 /*
1126 ** Provide a dummy Tcl_InitStubs if we are using this as a static
1127 ** library.
1128 */
1129 #ifndef USE_TCL_STUBS
1130 # undef  Tcl_InitStubs
1131 # define Tcl_InitStubs(a,b,c)
1132 #endif
1133 
1134 /*
1135 ** Initialize this module.
1136 **
1137 ** This Tcl module contains only a single new Tcl command named "sqlite".
1138 ** (Hence there is no namespace.  There is no point in using a namespace
1139 ** if the extension only supplies one new name!)  The "sqlite" command is
1140 ** used to open a new SQLite database.  See the DbMain() routine above
1141 ** for additional information.
1142 */
Sqlite_Init(Tcl_Interp * interp)1143 int Sqlite_Init(Tcl_Interp *interp){
1144   Tcl_InitStubs(interp, "8.0", 0);
1145   Tcl_CreateObjCommand(interp, "sqlite", (Tcl_ObjCmdProc*)DbMain, 0, 0);
1146   Tcl_PkgProvide(interp, "sqlite", "2.0");
1147   return TCL_OK;
1148 }
Tclsqlite_Init(Tcl_Interp * interp)1149 int Tclsqlite_Init(Tcl_Interp *interp){
1150   Tcl_InitStubs(interp, "8.0", 0);
1151   Tcl_CreateObjCommand(interp, "sqlite", (Tcl_ObjCmdProc*)DbMain, 0, 0);
1152   Tcl_PkgProvide(interp, "sqlite", "2.0");
1153   return TCL_OK;
1154 }
Sqlite_SafeInit(Tcl_Interp * interp)1155 int Sqlite_SafeInit(Tcl_Interp *interp){
1156   return TCL_OK;
1157 }
Tclsqlite_SafeInit(Tcl_Interp * interp)1158 int Tclsqlite_SafeInit(Tcl_Interp *interp){
1159   return TCL_OK;
1160 }
1161 
1162 #if 0
1163 /*
1164 ** If compiled using mktclapp, this routine runs to initialize
1165 ** everything.
1166 */
1167 int Et_AppInit(Tcl_Interp *interp){
1168   return Sqlite_Init(interp);
1169 }
1170 #endif
1171 /***************************************************************************
1172 ** The remaining code is only included if the TCLSH macro is defined to
1173 ** be an integer greater than 0
1174 */
1175 #if defined(TCLSH) && TCLSH>0
1176 
1177 /*
1178 ** If the macro TCLSH is defined and is one, then put in code for the
1179 ** "main" routine that implement a interactive shell into which the user
1180 ** can type TCL commands.
1181 */
1182 #if TCLSH==1
1183 static char zMainloop[] =
1184   "set line {}\n"
1185   "while {![eof stdin]} {\n"
1186     "if {$line!=\"\"} {\n"
1187       "puts -nonewline \"> \"\n"
1188     "} else {\n"
1189       "puts -nonewline \"% \"\n"
1190     "}\n"
1191     "flush stdout\n"
1192     "append line [gets stdin]\n"
1193     "if {[info complete $line]} {\n"
1194       "if {[catch {uplevel #0 $line} result]} {\n"
1195         "puts stderr \"Error: $result\"\n"
1196       "} elseif {$result!=\"\"} {\n"
1197         "puts $result\n"
1198       "}\n"
1199       "set line {}\n"
1200     "} else {\n"
1201       "append line \\n\n"
1202     "}\n"
1203   "}\n"
1204 ;
1205 #endif /* TCLSH==1 */
1206 
Libsqlite_Init(Tcl_Interp * interp)1207 int Libsqlite_Init( Tcl_Interp *interp) {
1208 #ifdef TCL_THREADS
1209   if (Thread_Init(interp) == TCL_ERROR) {
1210     return TCL_ERROR;
1211   }
1212 #endif
1213   Sqlite_Init(interp);
1214 #ifdef SQLITE_TEST
1215   {
1216     extern int Sqlitetest1_Init(Tcl_Interp*);
1217     extern int Sqlitetest2_Init(Tcl_Interp*);
1218     extern int Sqlitetest3_Init(Tcl_Interp*);
1219     extern int Md5_Init(Tcl_Interp*);
1220     Sqlitetest1_Init(interp);
1221     Sqlitetest2_Init(interp);
1222     Sqlitetest3_Init(interp);
1223     Md5_Init(interp);
1224     Tcl_StaticPackage(interp, "sqlite", Libsqlite_Init, Libsqlite_Init);
1225   }
1226 #endif
1227   return TCL_OK;
1228 }
1229 
1230 #define TCLSH_MAIN main   /* Needed to fake out mktclapp */
1231 #if TCLSH==1
TCLSH_MAIN(int argc,char ** argv)1232 int TCLSH_MAIN(int argc, char **argv){
1233 #ifndef TCL_THREADS
1234   Tcl_Interp *interp;
1235   Tcl_FindExecutable(argv[0]);
1236   interp = Tcl_CreateInterp();
1237   Libsqlite_Init(interp);
1238   if( argc>=2 ){
1239     int i;
1240     Tcl_SetVar(interp,"argv0",argv[1],TCL_GLOBAL_ONLY);
1241     Tcl_SetVar(interp,"argv", "", TCL_GLOBAL_ONLY);
1242     for(i=2; i<argc; i++){
1243       Tcl_SetVar(interp, "argv", argv[i],
1244           TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT | TCL_APPEND_VALUE);
1245     }
1246     if( Tcl_EvalFile(interp, argv[1])!=TCL_OK ){
1247       const char *zInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
1248       if( zInfo==0 ) zInfo = interp->result;
1249       fprintf(stderr,"%s: %s\n", *argv, zInfo);
1250       return TCL_ERROR;
1251     }
1252   }else{
1253     Tcl_GlobalEval(interp, zMainloop);
1254   }
1255   return 0;
1256 #else
1257   Tcl_Main(argc, argv, Libsqlite_Init);
1258 #endif /* TCL_THREADS */
1259   return 0;
1260 }
1261 #endif /* TCLSH==1 */
1262 
1263 
1264 /*
1265 ** If the macro TCLSH is set to 2, then implement a space analysis tool.
1266 */
1267 #if TCLSH==2
1268 static char zAnalysis[] =
1269 #include "spaceanal_tcl.h"
1270 ;
1271 
main(int argc,char ** argv)1272 int main(int argc, char **argv){
1273   Tcl_Interp *interp;
1274   int i;
1275   Tcl_FindExecutable(argv[0]);
1276   interp = Tcl_CreateInterp();
1277   Libsqlite_Init(interp);
1278   Tcl_SetVar(interp,"argv0",argv[0],TCL_GLOBAL_ONLY);
1279   Tcl_SetVar(interp,"argv", "", TCL_GLOBAL_ONLY);
1280   for(i=1; i<argc; i++){
1281     Tcl_SetVar(interp, "argv", argv[i],
1282         TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT | TCL_APPEND_VALUE);
1283   }
1284   if( Tcl_GlobalEval(interp, zAnalysis)!=TCL_OK ){
1285     const char *zInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
1286     if( zInfo==0 ) zInfo = interp->result;
1287     fprintf(stderr,"%s: %s\n", *argv, zInfo);
1288     return TCL_ERROR;
1289   }
1290   return 0;
1291 }
1292 #endif /* TCLSH==2 */
1293 
1294 #endif /* TCLSH */
1295 
1296 #endif /* NO_TCL */
1297