--- /dev/null
- /* Create the UserDb object supporting TCL "udb" command operations.
+/*
+** 2022 March 20
+**
+** The author disclaims copyright to this source code. In place of
+** a legal notice, here is a blessing:
+**
+** May you do good and not evil.
+** May you find forgiveness for yourself and forgive others.
+** May you share freely, never taking more than you give.
+**
+*************************************************************************
+** This file contains code to implement the "tclshext" shell extension
+** for use with the extensible "sqlite3" CLI shell. On *Nix, build thusly:
+ tool/mkshellc.tcl ext/misc/tclshext.c.in > tclshext.c
+ gcc -shared -fPIC -O2 -I. -Isrc -I/usr/include/tcl8.6 \
+ tclshext.c -o tclshext.so -ltcl8.6
+** Or, (after ./configure ...), use the provided Makefile thusly:
+ make tcl_shell_extension
+** If the Tk library is available, it can be linked and used thusly:
+ gcc -shared -fPIC -O2 -I. -Isrc -I/usr/include/tcl8.6 \
+ -DSHELL_ENABLE_TK tclshext.c -o tclshext.so -ltcl8.6 -ltk8.6
+** Or, make the same target with Tk thusly:
+ make tcl_shell_extension WITH_TK=1
+** Later TCL versions can be used if desired (and installed.)
+**
+** TCL scripting support is added with a registerScripting() call (in the
+** ShellExtensionAPI), meeting ScriptingSupport interface requirements.
+*/
+static const char * const zTclHelp =
+ "This extension adds these features to the host shell:\n"
+ " 1. TCL scripting support is added.\n"
+ " 2. TCL commands are added: udb shdb now_interactive get_tcl_group ..\n"
+ " 3. The .tcl and .unknown dot commands are added.\n"
+ " 4. If built with Tk capability, the gui TCL command will be added if this\n"
+ " extension was loaded using shell command: .load tclshext -shext -tk .\n"
+ " Any other arguments beyond -shext are copied into TCL's argv variable.\n"
+ "Operation:\n"
+ " Shell input groups beginning with \"..\" are treated as TCL input, in\n"
+ " these ways: (1) When a bare \"..\" is entered, a TCL REPL loop is run\n"
+ " until the end of input is seen; (2) When \"..D ...\" is entered, (where\n"
+ " \"D\" is a dot-command name), the D dot command will be run in its normal\n"
+ " fashion, but its arguments will be collected according to TCL parsing\n"
+ " rules then expanded as usual for TCL commands; and (3) when \".. T ...\"\n"
+ " is entered, (where \"T\" is a TCL command name), that TCL command and its\n"
+ " arguments will be collected and expanded according to TCL parsing rules,\n"
+ " then run in the TCL execution environment (in its global namespace), but\n"
+ " the shell REPL and execution environment remains in effect afterward.\n"
+ "\n"
+ " Note that cases 2 and 3 differ in having space after the leading \"..\".\n"
+ "\n"
+ " The phrase \"end of input\" means either: end-of-file is seen on a file,\n"
+ " pipe or string stream input, or a lone \".\" on the first and only line\n"
+ " of an input line group is seen. This convention is useful in scripting\n"
+ " when it is expedient to switch execution environments from within the\n"
+ " same input stream. This could be input piped in from another process.\n"
+ "\n"
+ ;
+/*
+** For example:
+ # From shell, enter TCL REPL:
+ ..
+ # Initialize some variables and insert into the DB:
+ set var1 [compute_however ...]
+ set var2 [derive_somehow ...]
+ udb eval { INSERT INTO SomeTable(col1, col2) VALUES($var1, var2) }
+ # Leave REPL
+ .
+ # Generate and keep pretty output:
+ .mode box -ww
+ .header on
+ .once prettified.txt
+ SELECT * FROM SomeTable;
+ # Alternatively, the query can be run from the TCL environment:
+ ..
+ set tstamp [clock format [clock seconds] -format %Y-%m-%d]
+ .once "backup of prettified.txt made $tstamp"
+ .eval {SELECT col1, col2 FROM SomeTable}
+ # Return to shell environment:
+ .
+**
+** For any of these ways of providing TCL input, the same TCL interpreter
+** is used, with its state maintained from one input to the next. In this
+** way, .sqliterc or other preparatory shell scripts (or typing) can be
+** made to provide useful, user-defined shell enhancements or specialized
+** procedures (aka "TCL commands") for oft-repeated tasks.
+**
+** The added TCL commands are:
+** udb shdb ; # exposes the user DB and shell DB for access via TCL
+** now_interactive ; # indicates whether current input is interactive
+** get_tcl_group ; # gets one TCL input line group from current input
+** register_adhoc_command ; # aids creation of dot commands with help
+** .. ; # does nothing, silently and without error
+**
+** The .. command exists so that a lone ".." on an input line suffices
+** to ensure the TCL REPL is running. This is symmetric with a lone "."
+** input to the TCL REPL because it either terminates the loop or, if
+** entered in the shell environment, quietly does nothing without error.
+**
+** The added .tcl dot command may be used to enter a TCL REPL, or with
+** arguments, it will read files as TCL. (This is somewhat extraneous,
+** as the same can be done with TCL commands, but it is more easily done
+** from the shell invocation, and the .tcl command's integration into
+** the .help facility provides a way for users to get help for "..".)
+**
+** The added .unknown dot command overrides the shell's .unknown so
+** that new dot commands can be implemented in TCL and then be run
+** from the shell in the dot command execution context.
+*/
+
+#include "shx_link.h"
+
+/* Extension boiler-plate to dynamically link into host's SQLite library */
+SQLITE_EXTENSION_INIT1;
+
+/* Extension boiler-plate for a function to get ShellExtensionLink pointer
+ * from db passed to extension init() and define a pair of static API refs.
+ */
+SHELL_EXTENSION_INIT1(pShExtApi, pExtHelpers, shextLinkFetcher);
+#define SHX_API(entry) pShExtApi->entry
+#define SHX_HELPER(entry) pExtHelpers->entry
+#define oprintf pExtHelpers->utf8CurrentOutPrintf
+
+/* This is not found in the API pointer table published for extensions: */
+#define sqlite3_enable_load_extension SHX_HELPER(enable_load_extension)
+
+/* Forward reference for use as ExtensionId */
+#ifdef _WIN32
+__declspec(dllexport)
+#endif
+int sqlite3_tclshext_init(sqlite3*, char**, const sqlite3_api_routines*);
+
+/* Control how tclsqlite.c compiles. (REPL is effected here, not there.) */
+#define STATIC_BUILD /* Not publishing TCL API */
+#undef SQLITE_AMALGAMATION
+#undef TCLSH
+#include "tclOO.h"
+#ifdef SHELL_ENABLE_TK
+#include "tk.h" /* Only used if option -tk passed during load. */
+#endif
+INCLUDE ../../src/tclsqlite.c
+
+#if defined(_WIN32) || defined(WIN32)
+# include <direct.h>
+# define getDir(cArray) _getcwd(cArray, sizeof(cArray))
+# define chdir(s) _chdir(s)
+#else
+# define getDir(cArray) getcwd(cArray, sizeof(cArray))
+#endif
+
+typedef struct TclCmd TclCmd;
+typedef struct UnkCmd UnkCmd;
+
+static struct InterpManage {
+ Tcl_Interp *pInterp;
+ int nRefs;
+} interpKeep = { 0, 0 };
+
+static Tcl_Interp *getInterp(){
+ assert(interpKeep.nRefs>0 && interpKeep.pInterp!=0);
+ return interpKeep.pInterp;
+}
+
+static void Tcl_TakeDown(void *pv){
+ assert(pv==&interpKeep);
+ if( --interpKeep.nRefs==0 ){
+ if( interpKeep.pInterp ){
+ Tcl_DeleteInterp(interpKeep.pInterp);
+ Tcl_Release(interpKeep.pInterp);
+ interpKeep.pInterp = 0;
+ Tcl_Finalize();
+ }
+ }
+}
+
+static int Tcl_BringUp(
+#ifdef SHELL_ENABLE_TK
+ int *pWithTk,
+#endif
+ char **pzErrMsg){
+ if( ++interpKeep.nRefs==1 ){
+ const char *zShellName = SHX_HELPER(shellInvokedAs)();
+ const char *zShellDir = SHX_HELPER(shellStartupDir)();
+ if( zShellDir!=0 ){
+ char cwd[FILENAME_MAX+1];
+ if( getDir(cwd) && 0==chdir(zShellDir) ){
+ int rc;
+ Tcl_FindExecutable(zShellName);
+ rc = chdir(cwd); /* result ignored, kept only to silence gcc */
+ }
+ }
+ interpKeep.pInterp = Tcl_CreateInterp();
+ Tcl_SetSystemEncoding(interpKeep.pInterp, "utf-8");
+ Sqlite3_Init(interpKeep.pInterp);
+ Tcl_Preserve(interpKeep.pInterp);
+ if( 0==Tcl_OOInitStubs(interpKeep.pInterp) ){
+ *pzErrMsg = sqlite3_mprintf("Tcl v8.6 or higher required.\n");
+ Tcl_TakeDown(&interpKeep);
+ return SQLITE_ERROR;
+ }
+ if( Tcl_Init(interpKeep.pInterp)!=TCL_OK ){
+ *pzErrMsg = sqlite3_mprintf("Tcl interpreter startup failed.\n");
+ Tcl_TakeDown(&interpKeep);
+ return SQLITE_ERROR;
+ }
+#ifdef SHELL_ENABLE_TK
+ else if( *pWithTk ){
+ if( TCL_OK!=Tk_Init(interpKeep.pInterp) ){
+ fprintf(stderr, "Could not load/initialize Tk."
+ " (Non-fatal, extension is loaded.)\n");
+ *pWithTk = 0;
+ }
+ }
+#endif
+ }
+ return (interpKeep.pInterp!=0)? SQLITE_OK : SQLITE_ERROR;
+}
+
+static void copy_complaint(char **pzErr, Tcl_Interp *pi);
+static DotCmdRC runTclREPL(Tcl_Interp *interp, char **pzErrMsg);
+
+/* Following DERIVED_METHOD(...) macro calls' arguments were copied and
+ * pasted from the respective interface declarations in shext_linkage.h
+ */
+
+/* This is in the interface for anouncing what was just provided. */
+DERIVED_METHOD(const char *, name, ScriptSupport,TclSS, 0,()){
+ (void)(pThis);
+ return "TclTk";
+}
+
+/* Provide help for users of this scripting implementation. */
+DERIVED_METHOD(const char *, help, ScriptSupport,TclSS, 1,(const char *zHK)){
+ (void)(pThis);
+ if( zHK==0 ){
+ return "Provides TCL scripting support for SQLite extensible shell.\n";
+ }else if( *zHK==0 ) return zTclHelp;
+ return 0;
+}
+
+/* Not doing this yet. */
+DERIVED_METHOD(int, configure, ScriptSupport,TclSS,
+ 4,( ShellExState *pSES, char **pzErr,
+ int numArgs, char *azArgs[] )){
+ (void)(pThis);
+ return 0;
+}
+
+/* Say line is script lead-in iff its first dark is "..".
+ * In combination with dot commands also being TCL commands and the
+ * special handling in the next three functions, this effects what is
+ * promised in this file's header text and by .tcl's help text.
+ */
+DERIVED_METHOD(int, isScriptLeader, ScriptSupport,TclSS,
+ 1,( const char *zScriptLeadingLine )){
+ char c;
+ (void)(pThis);
+ while( (c=*zScriptLeadingLine++) && (c==' '||c=='\t') ) {}
+ return (c=='.' && *zScriptLeadingLine=='.');
+}
+
+/* Say line group is complete if it passes muster as ready-to-go TCL. */
+DERIVED_METHOD(int, scriptIsComplete, ScriptSupport,TclSS,
+ 2,( const char *zScript, char **pzWhyNot )){
+ (void)(pThis);
+ (void)(pzWhyNot);
+ return Tcl_CommandComplete(zScript);
+}
+
+/* As we rely on Tcl_CommandComplete(), no resumable scanning is done. */
+DERIVED_METHOD(void, resetCompletionScan, ScriptSupport,TclSS, 0,()){
+ (void)(pThis);
+}
+
+/* Run as TCL after some jiggering with the leading dots. */
+DERIVED_METHOD(DotCmdRC, runScript, ScriptSupport,TclSS,
+ 3,( const char *zScript, ShellExState *psx, char **pzErrMsg )){
+ char c;
+ Tcl_Interp *interp = getInterp();
+ (void)(pThis);
+ (void)(psx);
+
+ if( interp==0 ) return DCR_Error;
+ while( (c=*zScript++) && (c==' '||c=='\t') ) {}
+ if( c=='.' && *zScript++=='.' ){
+ int rc = 0;
+ int nc = strlen30(zScript);
+ /* At this point, *zScript should fall into one of these cases: */
+ switch( *zScript ){
+ case '.':
+ /* Three dots, assume user meant to run a dot command. */
+ one_shot_tcl:
+ rc = Tcl_EvalEx(interp, zScript, /* needs no adjustment */
+ nc, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL);
+ if( rc!=TCL_OK ) copy_complaint(pzErrMsg, getInterp());
+ break;
+ case ' ': case '\t':
+ /* Two dots then whitespace, it's a TCL one-shot command. */
+ while( (c = *zScript)!=0 && c==' ' || c=='\t' ) ++zScript, --nc;
+ if ( c!=0 ) goto one_shot_tcl;
+ /* It looks like "..", so run it that way via fall-thru. */
+ case 0:
+ /* Two lone dots, user wants to run TCL REPL. */
+ return runTclREPL(interp, pzErrMsg);
+ default:
+ /* Two dots then dark not dot, may be a dot command. */
+ if( *zScript>='a' && *zScript<='z' ){
+ --zScript, ++nc;
+ goto one_shot_tcl;
+ }
+ /* It cannot be a dot command; a user tip is apparently needed. */
+ if( pzErrMsg ){
+ *pzErrMsg = sqlite3_mprintf("Nothing valid begins with ..%c\n"
+ "Run .help tcl to see what is valid.\n",
+ *zScript);
+ return DCR_SayUsage;
+ }
+ }
+ return DCR_Ok|(rc!=TCL_OK);
+ }
+ return DCR_Error; /* Silent error because it should not happen. */
+}
+
+DERIVED_METHOD(void, destruct, DotCommand,TclCmd, 0, ()){
+ /* Nothing to do, instance data is static. */
+ (void)(pThis);
+}
+static DERIVED_METHOD(void, destruct, DotCommand,UnkCmd, 0, ());
+
+DERIVED_METHOD(void, destruct, ScriptSupport,TclSS, 0, ()){
+ /* Nothing to do, instance data is static. */
+ (void)(pThis);
+}
+
+DERIVED_METHOD(const char *, name, DotCommand,TclCmd, 0,()){
+ return "tcl";
+}
+DERIVED_METHOD(const char *, name, DotCommand,UnkCmd, 0,()){
+ return "unknown";
+}
+
+DERIVED_METHOD(const char *, help, DotCommand,TclCmd, 1,(const char *zHK)){
+ (void)(pThis);
+ if( zHK==0 )
+ return
+ ".tcl ?FILES? Run a TCL REPL or interpret files as TCL.\n";
+ if( *zHK==0 )
+ return
+ " If FILES are provided, they name files to be read in as TCL.\n"
+ " Otherwise, a read/evaluate/print loop is run until a lone \".\" is\n"
+ " entered as complete TCL input or input end-of-stream is encountered.\n"
+ "\n"
+ " The same REPL can be run with a lone \"..\". Or the \"..\" prefix\n"
+ " may be used thusly, \"..dotcmd ...\" or \".. tclcmd ...\", to run a\n"
+ " single dot command or TCL command, respectively, whereupon it will\n"
+ " be run in its respective execution environment after its arguments\n"
+ " are collected using TCL parsing rules and expanded as for TCL in\n"
+ " the TCL base namespace. In this way, arguments may be \"computed\".\n"
+ ;
+ return 0;
+}
+
+DERIVED_METHOD(const char *, help, DotCommand,UnkCmd, 1,(const char *zHK));
+
+DERIVED_METHOD(DotCmdRC, argsCheck, DotCommand,TclCmd, 3,
+ (char **pzErrMsg, int nArgs, char *azArgs[])){
+ return DCR_Ok;
+}
+DERIVED_METHOD(DotCmdRC, argsCheck, DotCommand,UnkCmd, 3,
+ (char **pzErrMsg, int nArgs, char *azArgs[])){
+ return DCR_Ok;
+}
+
+static void copy_complaint(char **pzErr, Tcl_Interp *pi){
+ if( pzErr ){
+ Tcl_Obj *po = Tcl_GetObjResult(pi);
+ *pzErr = sqlite3_mprintf("%s\n", Tcl_GetStringFromObj(po,0));
+ }
+}
+
+/* The .tcl/.. REPL script is one of the 3 following string literals,
+ * selected at build time for these different purposes:
+ * 1st: a simple input collection, reading only stdin, which may
+ * be (handily) used as a fallback for debugging purposes.
+ * 2nd: input collection which honors the shell's input switching
+ * and otherwise has low dependency upon shell features, which
+ * means that it has no input line editing or history recall.
+ * 3rd: an input collection which fully leverages the shell's
+ * input collection. It has higher shell dependency, and for
+ * that it gains the shell's line editing and history recall,
+ * in addition to working with the shell's input switching.
+ * It also supports recursive REPLs when return is caught.
+ */
+#ifdef TCL_REPL_STDIN_ONLY
+# define TCL_REPL 1
+#elif defined(TCL_REPL_LOW_DEPENDENCY)
+# define TCL_REPL 2
+#else
+# define TCL_REPL 3
+#endif
+
+
+#if TCL_REPL==1 /* a fallback for debug */
+TCL_CSTR_LITERAL(static const char * const zREPL = ){
+ set line {}
+ while {![eof stdin]} {
+ if {$line!=""} {
+ puts -nonewline "> "
+ } else {
+ puts -nonewline "% "
+ }
+ flush stdout
+ append line [gets stdin]
+ if {$line eq "."} break
+ if {[info complete $line]} {
+ if {[catch {uplevel #0 $line} result]} {
+ puts stderr "Error: $result"
+ } elseif {$result!=""} {
+ puts $result
+ }
+ set line {}
+ } else {
+ append line \n
+ }
+ }
+ if {$line ne "."} {puts {}}
+ read stdin 0
+};
+#elif TCL_REPL==2 /* minimal use of shell's read */
+TCL_CSTR_LITERAL(static const char * const zREPL = ){
+ namespace eval ::REPL {
+ variable line {}
+ variable at_end 0
+ variable prompting [now_interactive]
+ }
+ while {!$::REPL::at_end} {
+ if {$::REPL::prompting} {
+ if {$::REPL::line!=""} {
+ puts -nonewline "...> "
+ } else {
+ puts -nonewline "tcl% "
+ }
+ }
+ flush stdout
+ set ::REPL::li [get_input_line]
+ if {$::REPL::li eq ""} {
+ set ::REPL::at_end 1
+ } elseif {[string trimright $::REPL::li] eq "."} {
+ if {$::REPL::line ne ""} {
+ throw {NONE} {incomplete input at EOF}
+ }
+ set ::REPL::at_end 1
+ } else {
+ append ::REPL::line $::REPL::li
+ if {[string trim $::REPL::line] eq ""} {
+ set ::REPL::line ""
+ continue
+ }
+ if {[info complete $::REPL::line]} {
+ set ::REPL::rc [catch {uplevel #0 $::REPL::line} ::REPL::result]
+ if {$::REPL::rc == 0} {
+ if {$::REPL::result!="" && $::REPL::prompting} {
+ puts $::REPL::result
+ }
+ } elseif {$::REPL::rc == 1} {
+ puts stderr "Error: $::REPL::result"
+ } elseif {$::REPL::rc == 2} {
+ set ::REPL::at_end 1
+ }
+ set ::REPL::line {}
+ }
+ }
+ }
+ if {$::REPL::prompting && $::REPL::li ne ".\n"} {puts {}}
+ namespace delete ::REPL
+ read stdin 0
+};
+#elif TCL_REPL==3
+/* using shell's input collection with line editing (if configured) */
+static const char * const zREPL = "uplevel #0 sqlite_shell_REPL";
+
+TCL_CSTR_LITERAL(static const char * const zDefineREPL = ){
+ proc sqlite_shell_REPL {} {
+ if {[info exists ::tcl_interactive]} {
+ set save_interactive $::tcl_interactive
+ }
+ set ::tcl_interactive [now_interactive]
+ while {1} {
+ foreach {group ready} [get_tcl_group] {}
+ set trimmed [string trim $group]
+ if {$group eq "" && !$ready} break
+ if {$trimmed eq ""} continue
+ if {!$ready && $trimmed ne ""} {
+ throw {NONE} {incomplete input at EOF}
+ }
+ if {$trimmed eq "."} break
+ set rc [catch {uplevel #0 $group} result]
+ if {$rc == 0} {
+ if {$result != "" && $::tcl_interactive} {
+ puts $result
+ }
+ } elseif {$rc == 1} {
+ puts stderr "Error: $result"
+ } elseif {$rc == 2} {
+ return -code 2
+ }
+ }
+ if {$::tcl_interactive && $trimmed ne "."} {puts {}}
+ read stdin 0
+ if {[info exists save_interactive]} {
+ set ::tcl_interactive $save_interactive
+ } else { unset ::tcl_interactive }
+ }
+};
+#else
+ "throw {NONE} {not built for REPL}\n"
+#endif
+
+/* Enter the preferred REPL */
+static DotCmdRC runTclREPL(Tcl_Interp *interp, char **pzErrMsg){
+ int rc = Tcl_Eval(interp, zREPL);
+ clearerr(stdin); /* Cure issue where stdin gets stuck after keyboard EOF. */
+ if( rc!=TCL_OK ){
+ copy_complaint(pzErrMsg, interp);
+ return DCR_Error;
+ }
+ return DCR_Ok;
+}
+
+DERIVED_METHOD(DotCmdRC, execute, DotCommand,TclCmd, 4,
+ (ShellExState *psx, char **pzErrMsg, int nArgs, char *azArgs[])){
+ TclCmd *ptc = (TclCmd *)pThis;
+ if( nArgs>1 ){
+ /* Read named files into the interpreter. */
+ int rc = TCL_OK;
+ int aix;
+ for( aix=0; aix<(nArgs-1) && rc==TCL_OK; ++aix ){
+ rc = Tcl_EvalFile(getInterp(), azArgs[aix+1]);
+ }
+ if( rc!=TCL_OK ){
+ copy_complaint(pzErrMsg, getInterp());
+ return DCR_Error;
+ }
+ return DCR_Ok;
+ }else{
+ /* Enter a REPL */
+ return runTclREPL(getInterp(), pzErrMsg);
+ }
+}
+
+DERIVED_METHOD(DotCmdRC, execute, DotCommand,UnkCmd, 4,
+ (ShellExState *psx, char **pzErrMsg, int nArgs, char *azArgs[])){
+ Tcl_Interp *interp = getInterp();
+ Tcl_Obj **ppo;
+ char zName[50];
+ int ia, rc;
+
+ if( interp==0 || nArgs==0 ) return DCR_Unknown;
+
+ sqlite3_snprintf(sizeof(zName), zName, ".%s", azArgs[0]);
+ if( !Tcl_FindCommand(interp, zName, 0, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) ){
+ if( !SHX_HELPER(nowInteractive)(psx) ){
+ *pzErrMsg = sqlite3_mprintf("Command %s not found.\n", zName);
+ return DCR_Unknown;
+ }else{
+ fprintf(stderr, "The %s command does not yet exist.\n", zName);
+ oprintf(psx, "Run .help to see existent dot commands,"
+ " or create %s as a TCL proc.\n", zName);
+ return DCR_CmdErred;
+ }
+ }
+ ppo = sqlite3_malloc((nArgs+1)*sizeof(Tcl_Obj*));
+ if( ppo==0 ) return TCL_ERROR;
+ for( ia=0; ia<nArgs; ++ia ){
+ ppo[ia] = Tcl_NewStringObj((ia)? azArgs[ia] : zName, -1);
+ Tcl_IncrRefCount(ppo[ia]);
+ }
+ rc = Tcl_EvalObjv(interp, nArgs, ppo, TCL_EVAL_GLOBAL);
+ for( ia=0; ia<nArgs; ++ia ) Tcl_DecrRefCount(ppo[ia]);
+ sqlite3_free(ppo);
+ /* Translate TCL return to a dot command return. */
+ switch( rc ){
+ case TCL_OK:
+ return DCR_Ok;
+ case TCL_ERROR:
+ *pzErrMsg = sqlite3_mprintf("%s\n", Tcl_GetStringResult(interp));
+ return DCR_Error;
+ case TCL_RETURN: case TCL_BREAK: case TCL_CONTINUE:
+ return DCR_Return;
+ default:
+ return DCR_Exit;
+ }
+}
+
+/* Define DotCommand v-tables initialized to reference most above methods. */
+DotCommand_IMPLEMENT_VTABLE(TclCmd, tclcmd_methods);
+DotCommand_IMPLEMENT_VTABLE(UnkCmd, unkcmd_methods);
+/* Define ScriptSupport v-table initialized to reference the others. */
+ScriptSupport_IMPLEMENT_VTABLE(TclSS, tclss_methods);
+
+/* Static instances are used because that suffices. */
+INSTANCE_BEGIN(TclCmd);
+ /* no instance data */
+INSTANCE_END(TclCmd) tclcmd = {
+ &tclcmd_methods
+};
+INSTANCE_BEGIN(TclSS);
+ /* no instance data */
+INSTANCE_END(TclSS) tclss = {
+ &tclss_methods
+};
+
+INSTANCE_BEGIN(UnkCmd);
+ /* no instance data */
+INSTANCE_END(UnkCmd) unkcmd = {
+ &unkcmd_methods
+};
+
+static DERIVED_METHOD(void, destruct, DotCommand,UnkCmd, 0, ()){
+ (void)(pThis);
+}
+
+DERIVED_METHOD(const char *, help, DotCommand,UnkCmd, 1,(const char *zHK)){
+ (void)(pThis);
+ if( !zHK )
+ return
+ ",unknown ?ARGS? Retry unknown dot command if it is a TCL command\n";
+ if( !*zHK )
+ return
+ " There is little use for this dot command without the TCL extension, as\n"
+ " the shell's version merely does some error reporting. However, with it\n"
+ " overridden, (as it is now), it provides a retry mechanism whereby, if\n"
+ " the command can be found defined in the TCL environment, that command\n"
+ " can be run with whatever arguments it was provided.\n"
+ "\n"
+ " If the TCL command, register_adhoc_command is run, this command's help\n"
+ " method can be made to provide help text for the registered TCL command.\n"
+ ;
+ return 0;
+}
+
+#if TCL_REPL==1 || TCL_REPL==2
+#define GETLINE_MAXLEN 1000
+
+/* C implementation of TCL proc, get_input_line */
+static int getInputLine(void *pvSS, Tcl_Interp *interp,
+ int nArgs, const char *azArgs[]){
+ if( nArgs==1 ){
+ char buffer[GETLINE_MAXLEN+1];
+ ShellExState *psx = (ShellExState *)pvSS;
+ struct InSource *pis = SHX_HELPER(currentInputSource)(psx);
+ if( SHX_HELPER(strLineGet)(buffer, GETLINE_MAXLEN, pis) ){
+ Tcl_SetResult(interp, buffer, TCL_VOLATILE);
+ }else{
+ Tcl_SetResult(interp, 0, 0);
+ }
+ return TCL_OK;
+ }else{
+ Tcl_SetResult(interp, "too many arguments", TCL_STATIC);
+ return TCL_ERROR;
+ }
+}
+#endif
+
+#if TCL_REPL==3
+/* C implementation of TCL proc, get_tcl_group
+ * This routine returns a 2 element list consisting of:
+ * the collected input lines, joined with "\n", as a string
+ * and
+ * the line group status, as an integer.
+ * The status is either 0, meaning input EOF was encountered,
+ * or 1, meaning the input is a complete TCL line group.
+ * There are only these return combinations:
+ * { Empty 0 } => no input obtained and no more to be had
+ * { Other 0 } => input collected, but is invalid TCL
+ * { Other 1 } => input collected, may be valid TCL
+ * By design, this combination is never returned:
+ * { Empty 1 } => no input collected but valid TCL
+ */
+static int getTclGroup(void *pvSS, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]){
+ if( objc==1 ){
+ static Prompts cueTcl = { "tcl% ", " > " };
+ ShellExState *psx = (ShellExState *)pvSS;
+ struct InSource *pis = SHX_HELPER(currentInputSource)(psx);
+ int isComplete = 0;
+ char *zIn = 0;
+ int isContinuation = 0;
+ do {
+ zIn = SHX_HELPER(oneInputLine)(pis, zIn, isContinuation, &cueTcl);
+ if( isContinuation ){
+ if( zIn ){
+ Tcl_AppendResult(interp, "\n", zIn, (char*)0);
+ isComplete = Tcl_CommandComplete(Tcl_GetStringResult(interp));
+ }
+ }else if( zIn ){
+ isComplete = Tcl_CommandComplete(zIn);
+ Tcl_SetResult(interp, zIn, TCL_VOLATILE);
+ }
+ isContinuation = 1;
+ } while( zIn && !isComplete );
+ if( zIn ) SHX_HELPER(freeInputLine)(zIn);
+ {
+ Tcl_Obj *const objvv[] = {
+ Tcl_NewStringObj(Tcl_GetStringResult(interp) , -1),
+ Tcl_NewIntObj(isComplete)
+ }; /* These unowned objects go directly into result, becoming owned. */
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, objvv));
+ }
+ return TCL_OK;
+ }else{
+ Tcl_SetResult(interp, "too many arguments", TCL_STATIC);
+ return TCL_ERROR;
+ }
+}
+#endif
+
+/* C implementation of TCL proc, now_interactive */
+static int nowInteractive(void *pvSS, Tcl_Interp *interp,
+ int nArgs, const char *azArgs[]){
+ if( nArgs==1 ){
+ ShellExState *psx = (ShellExState *)pvSS;
+ struct InSource *pis = SHX_HELPER(currentInputSource)(psx);
+ static const char * zAns[2] = { "0","1" };
+ int iiix = (SHX_HELPER(nowInteractive)(psx) != 0);
+ Tcl_SetResult(interp, (char *)zAns[iiix], TCL_STATIC);
+ return TCL_OK;
+ }else{
+ Tcl_SetResult(interp, "too many arguments", TCL_STATIC);
+ return TCL_ERROR;
+ }
+}
+
+#ifdef SHELL_ENABLE_TK
+static int numEventLoops = 0;
+static int inOuterLoop = 0;
+
+static int exitThisTkGUI(void *pvSS, Tcl_Interp *interp,
+ int nArgs, const char *azArgs[]){
+ if( numEventLoops==0 && !inOuterLoop ){
+ int ec = 0;
+ if( nArgs>=2 ){
+ if( azArgs[1] && sscanf(azArgs[1], "%d", &ec)!=1 ){
+ ec = 1;
+ fprintf(stderr, "Exit: %d\n", ec);
+ }else{
+ const char *zA = (azArgs[1])? azArgs[1] : "null";
+ fprintf(stderr, "Exit: \"%s\"\n", azArgs[1]);
+ }
+ }else{
+ fprintf(stderr, "Exit without argument\n");
+ }
+ fprintf(stderr, "Exit: \"%s\"\n", azArgs[1]);
+ // exit(ec);
+ }
+ --numEventLoops;
+ return TCL_BREAK;
+}
+
+static void runTclEventLoop(void){
+ int inOuter = inOuterLoop;
+ int nmw = Tk_GetNumMainWindows();
+ /* This runs without looking at stdin. So it cannot be a REPL, yet.
+ * Unless user has created something for it to do, it does nothing. */
+ /* Tk_MapWindow(Tk_MainWindow(interpKeep.pInterp)); */
+ ++numEventLoops;
+ inOuterLoop = 1;
+ while( nmw > 0 ) {
+ Tcl_DoOneEvent(0);
+ nmw = Tk_GetNumMainWindows();
+ /* if( nmw==1 ){ */
+ /* Tk_UnmapWindow(Tk_MainWindow(interpKeep.pInterp)); */
+ /* nmw = Tk_GetNumMainWindows(); */
+ /* break; */
+ /* } */
+ }
+ if( nmw==0 ){
+ fprintf(stderr,
+ "Tk application and its root window destroyed. Restarting Tk.\n");
+ Tk_Init(interpKeep.pInterp);
+ }
+ --numEventLoops;
+ inOuterLoop = inOuter;
+}
+
+static int runTkGUI(void *pvSS, Tcl_Interp *interp,
+ int nArgs, const char *azArgs[]){
+ (void)(pvSS); /* ShellExState *psx = (ShellExState *)pvSS; */
+ Tcl_SetMainLoop(runTclEventLoop);
+ runTclEventLoop();
+ return TCL_OK;
+}
+#endif /* defined(SHELL_ENABLE_TK) */
+
+#define UNKNOWN_RENAME "_original_unknown"
+
+/* C implementation of TCL ::register_adhoc_command name ?help? */
+static int registerAdHocCommand(/* ShellExState */ void *pv,
+ Tcl_Interp *interp,
+ int nArgs, const char *azArgs[]){
+ ShellExState *psx = (ShellExState*)pv;
+ if( nArgs>3 ){
+ Tcl_SetResult(interp, "too many arguments", TCL_STATIC);
+ }else if( nArgs<2 ){
+ Tcl_SetResult(interp, "too few arguments", TCL_STATIC);
+ }else{
+ const char *zHT = (nArgs==3)? azArgs[2] : 0;
+ Tcl_ResetResult(interp);
+ SHX_API(registerAdHocCommand)(psx, sqlite3_tclshext_init, azArgs[1], zHT);
+ return TCL_OK;
+ }
+ return TCL_ERROR;
+}
+
+/* C implementation of TCL unknown to (maybe) delegate to dot commands */
+static int unknownDotDelegate(void *pvSS, Tcl_Interp *interp,
+ int nArgs, const char *azArgs[]){
+ const char *name = (nArgs>1 && *azArgs[1]=='.')? azArgs[1]+1 : 0;
+ ShellExState *psx = (ShellExState *)pvSS;
+ DotCommand *pdc = 0;
+ int nFound = 0;
+ int ia, rc;
+
+ if( name ) pdc = SHX_HELPER(findDotCommand)(name, psx, &nFound);
+ if( pdc==(DotCommand*)&tclcmd && nArgs==2 ){
+ /* Will not do a nested REPL, just silently semi-fake it. */
+ return TCL_OK;
+ }
+ if( pdc && nFound==1 ){
+ /* Run the dot command and interpret its returns. */
+ DotCmdRC drc = SHX_HELPER(runDotCommand)(pdc, (char **)azArgs+1,
+ nArgs-1, psx);
+ if( drc==DCR_Ok ) return TCL_OK;
+ else if( drc==DCR_Return ){
+ return TCL_RETURN;
+ }else{
+ Tcl_AppendResult(interp, "Execution of .", name, " failed.", 0);
+ return TCL_ERROR;
+ }
+ }else{
+ /* Defer to the TCL-default unknown command, or fail here. */
+ if( 0!=Tcl_FindCommand(interp, UNKNOWN_RENAME, 0, TCL_GLOBAL_ONLY) ){
+ Tcl_Obj **ppo = sqlite3_malloc((nArgs+1)*sizeof(Tcl_Obj*));
+ if( ppo==0 ) return TCL_ERROR;
+ ppo[0] = Tcl_NewStringObj(UNKNOWN_RENAME, -1);
+ Tcl_IncrRefCount(ppo[0]);
+ for( ia=1; ia<nArgs; ++ia ){
+ ppo[ia] = Tcl_NewStringObj(azArgs[ia], -1);
+ Tcl_IncrRefCount(ppo[ia]);
+ }
+ ppo[ia] = 0;
+ rc = Tcl_EvalObjv(interp, nArgs, ppo, TCL_EVAL_GLOBAL);
+ for( ia=0; ia<nArgs; ++ia ) Tcl_DecrRefCount(ppo[ia]);
+ sqlite3_free(ppo);
+ return rc;
+ }else{
+ /* Fail now (instead of recursing back into this handler.) */
+ Tcl_AppendResult(interp,
+ "Command ", azArgs[1], " does not exist.", (char *)0);
+ return TCL_ERROR;
+ }
+ }
+}
+
+/* TCL dbu command: Acts like a (TCL) sqlite3 command created object except
+ * that it defers to shell's DB and treats the close subcommand as an error.
+ * The below struct and functions through userDbInit() support this feature.
+ */
+typedef struct UserDb {
+ SqliteDb **ppSdb; /* Some tclsqlite.c "sqlite3" DB objects, held here. */
+ int numSdb; /* How many "sqlite3" objects are now being held */
+ int ixuSdb; /* Which held "sqlite3" object is the .dbUser, if any */
+ int nRef; /* TCL object sharing counter */
+ Tcl_Interp *interp; /* For creation of newly visible .dbUser DBs */
+ ShellExState *psx; /* For shell state access when .eval is run */
+} UserDb;
+
+/* Add a DB to the list. Return its index. */
+static int udbAdd(UserDb *pudb, sqlite3 *udb){
+ SqliteDb *p;
+ pudb->ppSdb
+ = (SqliteDb**)Tcl_Realloc((char*)pudb->ppSdb, (pudb->numSdb+1)*sizeof(p));
+ memset(pudb->ppSdb + pudb->numSdb, 0, sizeof(SqliteDb*));
+ p = (SqliteDb*)Tcl_Alloc(sizeof(SqliteDb));
+ memset(p, 0, sizeof(SqliteDb));
+ pudb->ppSdb[pudb->numSdb] = p;
+ p->db = udb;
+ p->interp = pudb->interp;
+ p->maxStmt = NUM_PREPARED_STMTS;
+ p->openFlags = SQLITE_OPEN_URI;
+ p->nRef = 1;
+ return pudb->numSdb++;
+}
+
+/* Remove a DB from the list */
+static void udbRemove(UserDb *pudb, int ix){
+ SqliteDb *pdb;
+ assert(ix>=0 && ix<pudb->numSdb);
+ /* The code below is highly dependent upon implementation details of
+ * tclsqlite.c , and may become incorrect if that code changes. This
+ * is an accepted downside of reusing vast portions of that code.
+ * The minutiae in these comments is to explain the dependencies so
+ * that adjustments might be easily made when proven necessary. */
+ pdb = pudb->ppSdb[ix];
+#ifndef SQLITE_OMIT_INCRBLOB
+ /* This is a preemptive action, which is normally done by the
+ * delDatabaseRef() routine, which needs a non-zero db pointer
+ * to reach Tcl_UnregisterChannel()'s implementation. We do it
+ * now because, to avoid closing that db, that pointer will be
+ * set to 0 when delDatabaseRef() runs. */
+ closeIncrblobChannels(pdb);
+ /* Prevent closeIncrblobChannels() from trying to free anything. */
+ pdb->pIncrblob = 0;
+#endif
+ /* This appears to not be necessary; it is defensive in case the
+ * flushStmtCache() or dbFreeStmt() code begins to use pdb->db .
+ * We rely on its behavior whereby, once flushed, the cache is
+ * made to appear empty in the SqliteDb struct. */
+ flushStmtCache(pdb);
+ /* This next intervention prevents delDatabaseRef() from closing
+ * the .db ; this relies on sqlite3_close(0) being a NOP. If the
+ * SqliteDb takedown code changes, this may lead to an address
+ * fault. For that reason, the *.in which produces this source
+ * should be tested by excercising the TCL udb command well. */
+ pdb->db = 0;
+ assert(pdb->nRef==1);
+ /* Use the "stock" delete for sqlite3-generated objects. */
+ delDatabaseRef(pdb);
+ /* At this point, pdb has been Tcl_Free()'ed. Forget it. */
+ --pudb->numSdb;
+ {
+ int nshift = pudb->numSdb-ix;
+ if( nshift>0 ){
+ memmove(pudb->ppSdb+ix, pudb->ppSdb+ix+1, nshift*sizeof(pdb));
+ }
+ }
+ /* Adjust index to currently visible DB. */
+ if( ix==pudb->ixuSdb ) pudb->ixuSdb = -1;
+ else if( ix<pudb->ixuSdb ) --pudb->ixuSdb;
+}
+
+static struct UserDb *udbCreate(Tcl_Interp *interp, ShellExState *psx);
+
+/* Cleanup the UserDb singleton. Should only be done at shutdown.
+ * This routine is idempotent, and may be called redundantly.
+ */
+static void udbCleanup(UserDb *pudb){
+ /* If this is called too early, when *pudb is still associated with
+ * active (not yet closed) SqliteDb objects, those will simply be
+ * orphaned and leaked. But this assert may make the error evident. */
+ if( pudb==0 ) pudb = udbCreate(0, 0);
+ assert(pudb->numSdb==0);
+ if( pudb->ppSdb ) Tcl_Free((char*)pudb->ppSdb);
+ memset(pudb, 0, sizeof(UserDb));
+ pudb->ixuSdb = -1;
+}
+
+/* Hunt for given db in UserDb's list. Return its index if found, else -1. */
+static int udbIndexOfDb(UserDb *pudb, sqlite3 *psdb){
+ int ix = 0;
+ while( ix < pudb->numSdb ){
+ if( psdb==pudb->ppSdb[ix]->db ) return ix;
+ else ++ix;
+ }
+ return -1;
+}
+
+/* The event handler used to keep udb command's wrapped DB in sync with
+ * changes to the ShellExState .dbUser member. This task is complicated
+ * by effects of these dot commands: .open ; .connection ; and .quit,
+ * .exit or various other shell exit causes. The intention is to always
+ * have an orderly and leak-free shutdown (excepting kill/OOM aborts.)
+ */
+static int udbEventHandle(void *pv, NoticeKind nk, void *pvSubject,
+ ShellExState *psx){
+ UserDb *pudb = (UserDb*)pv;
+ if( nk==NK_ShutdownImminent ){
+ udbCleanup(pudb);
+ }else if( nk==NK_Unsubscribe ){
+ assert(pudb==0 || pudb->numSdb==0);
+ }else if( nk==NK_DbUserAppeared || nk==NK_DbUserVanishing
+ || nk==NK_DbAboutToClose || nk==NK_ExtensionUnload ){
+ sqlite3 *dbSubject = (sqlite3*)pvSubject;
+ int ix = udbIndexOfDb(pudb, dbSubject);
+ switch( nk ){
+ case NK_DbUserAppeared:
+ if( ix>=0 ) pudb->ixuSdb = ix;
+ else pudb->ixuSdb = udbAdd(pudb, dbSubject);
+ break;
+ case NK_DbUserVanishing:
+ if( ix>=0 ) pudb->ixuSdb = -1;
+ break;
+ case NK_ExtensionUnload:
+ SHX_API(subscribeEvents)(psx, sqlite3_tclshext_init, 0,
+ NK_Unsubscribe, udbEventHandle);
+ /* fall thru */
+ case NK_DbAboutToClose:
+ if( ix>=0 ) udbRemove(pudb, ix);
+ break;
++
++ /* Only above need handling. (So, clever tools, be quiet!) */
++ default: break;
+ }
+ }
+ return 0;
+}
+
++/* Create the UserDb object supporting TCL "udb" command operations.
+ * It's not wholly created because it is a singleton. Any subsequent
+ * creation is ignored; instead, the singleton is returned. This
+ * object is made to release resources only upon shutdown. If a TCL
+ * user removes the udb command, this avoids problems arising from
+ * this object holding references to databases that may still be in
+ * use, either as the active .dbUser or as a blob streaming store. */
+static struct UserDb *udbCreate(Tcl_Interp *interp, ShellExState *psx){
+ static UserDb *rv = 0;
+ static UserDb udb = { 0 };
+ if( interp==0 || psx==0 ) return &udb;
+ if( rv==0 ){
+ sqlite3 *sdbS = psx->dbShell;
+ sqlite3 *sdbU = psx->dbUser;
+ rv = &udb;
+ rv->interp = interp;
+ rv->psx = psx;
+ rv->ppSdb = (SqliteDb**)Tcl_Alloc(6*sizeof(SqliteDb*));
+ memset(rv->ppSdb, 0, 6*sizeof(SqliteDb*));
+ assert(sdbS!=0);
+ udbAdd(rv, sdbS);
+ if( sdbU!=0 ){
+ rv->ixuSdb = udbAdd(rv, sdbU);
+ } else rv->ixuSdb = -1;
+ rv->nRef = 1;
+ /* Arrange that this object tracks lifetimes and visibility of the
+ * ShellExState .dbUser member values which udb purports to wrap,
+ * and that shdb ceases wrapping the .dbShell member at shutdown.
+ * This subscription eventually leads to a udbCleanup() call. */
+ SHX_API(subscribeEvents)(psx, sqlite3_tclshext_init,
+ rv, NK_CountOf, udbEventHandle);
+ }
+ return rv;
+}
+
+static const char *azDbNames[] = { "shdb", "udb", 0 };
+static const int numDbNames = 2;
+
+/* C implementation behind added TCL udb command */
+static int UserDbObjCmd(void *cd, Tcl_Interp *interp,
+ int objc, Tcl_Obj * const * objv){
+ UserDb *pudb = (UserDb*)cd;
+ static const char *azDoHere[] = { "close", 0 };
+ enum DbDoWhat { DDW_Close };
+ int doWhat = -1;
+ int whichDb = -1;
+ const char *zMoan;
+
+ if( Tcl_GetIndexFromObj(interp, objv[0], azDbNames,
+ "shell DB command", 0, &whichDb)){
+ zMoan = " is not a wrapped DB.\n";
+ goto complain_fail;
+ }
+ if( whichDb>0 ) whichDb = pudb->ixuSdb;
+ /* Delegate all subcommands except above to the now-visible SqliteDb. */
+ if( objc>=2
+ && TCL_OK==Tcl_GetIndexFromObj(0, objv[1], azDoHere, "", 0, &doWhat)){
+ switch( doWhat ){
+ case DDW_Close:
+ zMoan = " close disallowed. It is a wrapped DB belonging to the shell.";
+ goto complain_fail;
+ default: ; /* Fine */
+ }
+ }
+ if( pudb->numSdb==0 || whichDb<0 ){
+ zMoan = " references no DB yet.\n";
+ goto complain_fail;
+ }
+ return DbObjCmd(pudb->ppSdb[whichDb], interp, objc, objv);
+
+ complain_fail:
+ Tcl_AppendResult(interp,
+ Tcl_GetStringFromObj(objv[0], (int*)0), zMoan, (char*)0);
+ return TCL_ERROR;
+}
+
+/* Get the udb command subsystem initialized and create "udb" TCL command. */
+static int userDbInit(Tcl_Interp *interp, ShellExState *psx){
+ UserDb *pudb = udbCreate(interp, psx);
+ int nCreate = 0;
+ int ic;
+ for( ic=0; ic<numDbNames; ++ic ){
+ nCreate +=
+ 0 != Tcl_CreateObjCommand(interp, azDbNames[ic],
+ (Tcl_ObjCmdProc*)UserDbObjCmd,
+ (char *)pudb, 0);
+ }
+ if( nCreate==ic ){
+ ++pudb->nRef;
+ return TCL_OK;
+ }
+ return TCL_ERROR;
+}
+
+/*
+** Extension load function.
+*/
+#ifdef _WIN32
+__declspec(dllexport)
+#endif
+int sqlite3_tclshext_init(
+ sqlite3 *db,
+ char **pzErrMsg,
+ const sqlite3_api_routines *pApi
+){
+ static const char * const azLoadFailures[] = {
+ "Extension load failed unexpectedly.",
+ "No ShellExtensionLink.\n Use '.load tclshext -shext' to load.",
+ "Outdated shell host extension API.\n Update the shell.",
+ "Outdated shell host helper API.\n Use a newer shell.",
+ };
+ int iLoadStatus;
+ SQLITE_EXTENSION_INIT2(pApi);
+ SHELL_EXTENSION_INIT2(pShExtLink, shextLinkFetcher, db);
+
+ SHELL_EXTENSION_INIT3(pShExtApi, pExtHelpers, pShExtLink);
+ iLoadStatus = SHELL_EXTENSION_LOADFAIL_WHY(pShExtLink, 6, 10);
+ if( iLoadStatus!=EXLD_Ok ){
+ if( iLoadStatus>=sizeof(azLoadFailures)/sizeof(azLoadFailures[0]) ){
+ iLoadStatus = 0;
+ }
+ *pzErrMsg = sqlite3_mprintf("%s\n", azLoadFailures[iLoadStatus]);
+ return SQLITE_ERROR;
+ }else{
+ ShellExState *psx = pShExtLink->pSXS;
+ Tcl_Obj *targv = Tcl_NewListObj(0, NULL);
+ const char *zAppName = "tclshext";
+ int tnarg = 0;
+#ifdef SHELL_ENABLE_TK
+ int ldTk = 0;
+#endif
+ int rc = 0;
+
+ if( pShExtLink->nLoadArgs>0 ){
+ int ila;
+ for( ila=0; ila<pShExtLink->nLoadArgs; ++ila ){
+ const char *zA = pShExtLink->azLoadArgs[ila];
+ if( strcmp(zA,"-tk")==0 ){
+#ifdef SHELL_ENABLE_TK
+ ldTk = 1;
+#else
+ *pzErrMsg = sqlite3_mprintf("Option -tk not supported by this "
+ "tclshext extension as built.\n");
+ return SQLITE_ERROR;
+#endif
+ }else{
+ /* Collect args not affecting init into the argv list. */
+ Tcl_ListObjAppendElement(NULL, targv, Tcl_NewStringObj(zA, -1));
+ ++tnarg;
+ }
+ }
+ }
+ rc = SHX_API(registerDotCommand)(psx, sqlite3_tclshext_init,
+ (DotCommand *)&unkcmd);
+ rc = SHX_API(registerDotCommand)(psx, sqlite3_tclshext_init,
+ (DotCommand *)&tclcmd);
+ if( rc==SQLITE_OK &&
+ (rc = Tcl_BringUp(
+#ifdef SHELL_ENABLE_TK
+ &ldTk,
+#endif
+ pzErrMsg))==SQLITE_OK
+ ){
+ Tcl_Interp *interp = getInterp();
+ if( TCL_OK==userDbInit(interp, psx) ){
+ UserDb *pudb = udbCreate(interp, psx);
+ pShExtLink->extensionDestruct = (void (*)(void*))udbCleanup;
+ pShExtLink->pvExtensionObject = pudb;
+ }
+ SHX_API(registerScripting)(psx, sqlite3_tclshext_init,
+ (ScriptSupport *)&tclss);
+#if TCL_REPL==1 || TCL_REPL==2
+ Tcl_CreateCommand(interp, "get_input_line", getInputLine, psx, 0);
+#endif
+#if TCL_REPL==3
+ Tcl_CreateObjCommand(interp, "get_tcl_group", getTclGroup, psx, 0);
+ Tcl_Eval(interp, zDefineREPL);
+#endif
+ Tcl_CreateCommand(interp, "now_interactive", nowInteractive, psx, 0);
+ /* Rename unknown so that calls to it can be intercepted. */
+ Tcl_Eval(interp, "rename unknown "UNKNOWN_RENAME);
+ Tcl_CreateCommand(interp, "unknown", unknownDotDelegate, psx, 0);
+ /* Add a command to facilitate ad-hoc TCL dot commands showing up in
+ * the .help output with help text as specified by calling this: */
+ Tcl_CreateCommand(interp, "register_adhoc_command",
+ registerAdHocCommand, (void*)psx, 0);
+
+ /* Define this proc so that ".." either gets to the TCL REPL loop
+ * or does nothing (if already in it), as a user convenience. */
+ Tcl_Eval(interp, "proc .. {} {}");
+#ifdef SHELL_ENABLE_TK
+ if( ldTk ){
+ /* Create a proc to launch GUI programs, in faint mimicry of wish.
+ *
+ * Its first argument, pgmName is the name to be given to the GUI
+ * program that may be launched, used for error reporting and to
+ * become the value of the ::argv0 that it sees.
+ *
+ * Its second argument, pgmSetup, will be executed as a list (of
+ * a command and its arguments) to setup the GUI program. It may
+ * do anything necessary to prepare for the GUI program to be
+ * run by running a Tk event loop. It may be an empty list, in
+ * which case pgmName must name a list serving the same purpose.
+ *
+ * Subsequent arguments to this proc will be passed to the GUI
+ * program in the ::argv/::argc variable pair it sees.
+ *
+ * If only two empty arguments are provided to this proc, (whether
+ * as defaulted or explictly passed), the GUI event loop will be
+ * run with whatever conditions have been setup prior to the call.
+ * (This is perfectly legitimate; this "gui" proc provides a way
+ * to package GUI preparation and separate it from GUI run.)
+ *
+ * It is the responsibility of whatever setup code is run, if any,
+ * to leave Tk objects and variables set so that when a GUI event
+ * loop is run, some useful GUI program runs and can terminate.
+ *
+ * Before running the setup code, a variable, ::isHost, is set
+ * true to possibly inform the setup code that it should avoid
+ * exit and exec calls. Setup code which is designed for either
+ * hosted or standalone use, when run with $::isHost!=0, may opt
+ * to leave variables ::exitCode and ::resultValue set which are
+ * taken to indicate pseudo-exit status and a string result to
+ * be used for error reporting or possibly other purposes.
+ *
+ * If the above responsibilities cannot be met, setup code should
+ * fail in some way so that its execution produces a TCL error or
+ * follows the ::exitCode and ::resultValue convention. Otherwise,
+ * annoying sqlite3 shell hangs or abrupt exits may result.
+ */
+ TCL_CSTR_LITERAL(const char * const zGui =){
+ proc gui {{pgmName ""} {pgmSetup {}} args} {
+ unset -nocomplain ::exitCode
+ set ::tcl_interactive [now_interactive]
+ set saveArgs [list $::argv0 $::argc $::argv]
+ if {"$pgmName" ne ""} {
+ set ::argv0 $pgmName
+ } else {set ::argv0 "?"}
+ set ::argv $args
+ set ::argc [llength $args]
+ if {[llength $pgmSetup] == 0 && $pgmName ne ""} {
+ if { [catch {set ::programSetup [subst "\$$pgmName"]}] } {
+ foreach {::argv0 ::argc ::argv} $saveArgs {}
+ return -code 1 "Error: pgmSetup empty, and pgmName does not\
+ name a list that might be\n executed in\
+ its place. Consult tclshext doc on using the gui command."
+ }
+ } elseif {[llength $pgmSetup] == 0 && $pgmName eq ""} {
+ unset -nocomplain ::programSetup
+ } else {
+ set ::programSetup $pgmSetup
+ }
+ if {[info exists ::programSetup] && [llength $::programSetup] > 0} {
+ set rc [catch {uplevel #0 {
+ {*}$::programSetup
+ }} result options]
+ if {$rc==1} {
+ puts stderr "gui setup failed: $result"
+ puts stderr [dict get $options -errorinfo]
+ } elseif {[info exists ::exitCode] && $::exitCode!=0} {
+ puts stderr "gui setup failed: $::resultValue"
+ } else { run_gui_event_loop }
+ } else {
+ run_gui_event_loop
+ }
+ foreach {::argv0 ::argc ::argv} $saveArgs {}
+ }
+ };
+ /* Create a command which nearly emuluates Tk_MainLoop(). It runs a
+ * GUI event loop, so does not return until either: all Tk top level
+ * windows are destroyed, which causes and error return, or the Tk
+ * app has called the replacement exit routine described next. */
+ Tcl_CreateCommand(interp, "run_gui_event_loop", runTkGUI, psx, 0);
+ Tcl_Eval(interp, "rename exit process_exit");
+ Tcl_CreateCommand(interp, "exit", exitThisTkGUI, psx, 0);
+ Tcl_Eval(interp, zGui);
+ Tcl_SetMainLoop(runTclEventLoop);
+ zAppName = "tclshext_tk";
+ }
+#endif /* ..TK */
+ Tcl_SetVar2Ex(interp, "::argv0", NULL,
+ Tcl_NewStringObj(zAppName,-1), TCL_GLOBAL_ONLY);
+ Tcl_SetVar2Ex(interp, "::argc", NULL,
+ Tcl_NewIntObj(tnarg), TCL_GLOBAL_ONLY);
+ Tcl_SetVar2Ex(interp, "::argv", NULL, targv, TCL_GLOBAL_ONLY);
+ Tcl_SetVar2Ex(interp, "::tcl_interactive", NULL,
+ Tcl_NewIntObj(SHX_HELPER(nowInteractive)(psx)),
+ TCL_GLOBAL_ONLY);
+ Tcl_SetVar2Ex(interp, "::isHosted", NULL,
+ Tcl_NewIntObj(1), TCL_GLOBAL_ONLY);
+ pShExtLink->eid = sqlite3_tclshext_init;
+ }
+ if( rc==SQLITE_OK ){
+ pShExtLink->extensionDestruct = Tcl_TakeDown;
+ pShExtLink->pvExtensionObject = &interpKeep;
+ }else{
+ Tcl_TakeDown(&interpKeep);
+ }
+ return rc;
+ }
+}
projects / thirdparty / sqlite.git / commitdiff
