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