/** \brief initialize the tclmsgque package
*
* The tclmsgque package is created and one new command "msgque"
* is added to the Tcl interpreter.
* \param[in] interp the current interpreter
* \return Tcl error-code
*/
TCLMQ_EXTERN int
Tclmsgque_Init (
Tcl_Interp * interp
)
{
// check for the reight tcl
if (Tcl_InitStubs (interp, "8.5", 0) == NULL) {
return TCL_ERROR;
}
// announce my package
TclErrorCheck (Tcl_PkgProvide (interp, "TclMsgque", LIBMSGQUE_VERSION));
// provide "msgque" as only public cammand of the package
Tcl_CreateObjCommand (interp, "tclmsgque", NS(MsgqueCmd), (ClientData) NULL,
(Tcl_CmdDeleteProc *) NULL);
// init libmsgque global data
if (MqInitGet() == NULL && Tcl_GetNameOfExecutable() != NULL) {
struct MqBufferLS * initB = MqInitCreate();
if (Tcl_Eval(interp, "info script") == TCL_ERROR)
return TCL_ERROR;
MqBufferLAppendC(initB, Tcl_GetNameOfExecutable());
MqBufferLAppendC(initB, Tcl_GetStringResult(interp));
}
// create the default-factory
if (!strcmp(MqFactoryDefaultIdent(),"libmsgque")) {
MqFactoryDefault("tclmsgque", NS(FactoryCreate), NULL, NULL, NS(FactoryDelete), NULL, NULL);
}
return TCL_OK;
}
int NS(LinkCreateChild) (NS_ARGS)
{
// check for connected
struct MqS * parent;
// get the parent tclctx
if (objc < 3 || NS(GetClientData) (interp, objv[skip], (MQ_PTR*) &parent) == TCL_ERROR) {
Tcl_WrongNumArgs (interp, 2, objv, "parent ...");
return TCL_ERROR;
} else {
SETUP_mqctx
struct MqBufferLS *args = NULL;
int i;
skip++;
// copy data entries
MqErrorCheck (MqSetupDup (mqctx, parent));
// command-line arguments to MqBufferLS
if (objc-skip > 0) {
args = MqBufferLCreate (objc-skip+1);
MqBufferLAppendC (args, (const MQ_STR) Tcl_GetNameOfExecutable());
for (i = skip; i < objc; i++) {
MqBufferLAppendC (args, Tcl_GetString (objv[i]));
}
}
// create Context
ErrorMqToTclWithCheck (MqLinkCreateChild(mqctx, parent, &args));
RETURN_TCL
}
}
/*
* Public entry point for ::tcl::kitpath.
* Creates both link variable name and Tcl command ::tcl::kitpath.
*/
static int
TclKitPath_Init(Tcl_Interp *interp)
{
Tcl_CreateObjCommand(interp, "::tcl::kitpath", TclKitPathObjCmd, 0, 0);
if (Tcl_LinkVar(interp, "::tcl::kitpath", (char *) &tclKitPath,
TCL_LINK_STRING | TCL_LINK_READ_ONLY) != TCL_OK) {
Tcl_ResetResult(interp);
}
if (tclKitPath == NULL) {
/*
* XXX: We may want to avoid doing this to allow tcl::kitpath calls
* XXX: to obtain changes in nameofexe, if they occur.
*/
TclKit_SetKitPath(Tcl_GetNameOfExecutable());
}
return Tcl_PkgProvide(interp, "tclkitpath", "1.0");
}
int NS(LinkCreate) (NS_ARGS)
{
SETUP_mqctx
struct MqBufferLS * args = NULL;
// command-line arguments to MqBufferLS
if (objc-skip > 0) {
int i;
args = MqBufferLCreate (objc-skip+1);
MqBufferLAppendC (args, (const MQ_STR) Tcl_GetNameOfExecutable());
for (i = skip; i < objc; i++) {
MqBufferLAppendC (args, Tcl_GetString (objv[i]));
}
}
// create Context
ErrorMqToTclWithCheck (MqLinkCreate(mqctx, &args));
RETURN_TCL
}
int Tcl_AppInit(Tcl_Interp *interp){
// Tcl_Init(interp);
// Tcl_SourceRCFile(interp);
//Tcl_SetStartupScript("/remote/us01home19/szhang/scratch/disk.dc/dc2nwtn/misc/tcltrace.tcl",NULL);
// parse_tcl_command(interp);
// Tcl_AllowExceptions(interp);
Parsetcl_Init(interp);
Tcl_StaticPackage(interp, "Parsetcl", Parsetcl_Init, NULL);
/*
if(TCL_OK != Tcl_Eval(interp,"load {} Parsetcl")){
printf("Error: load error\n");
}
*/
char buf[512];
const char *name = Tcl_GetNameOfExecutable();
sprintf(buf, "%s.lib.tcl", name);
Tcl_EvalFile(interp, buf);
//Tcl_Obj *startup = Tcl_GetStartupScript(NULL);
//parse_tcl_file(interp,"dcp558_gif_fp.cstr.tcl");
/*
int level = 0;
int flags = 0; // TCL_ALLOW_INLINE_COMPILATION
Tcl_CmdObjTraceProc *objProc = Tcl_CmdObjTraceProc_impl;
ClientData clientData = 0;
Tcl_CmdObjTraceDeleteProc *deleteProc=NULL;
Tcl_CreateObjTrace(interp, level, flags, objProc, clientData, deleteProc);
*/
// Tcl_Eval(interp,"exit");
return TCL_OK;
}
/*
* Accessor to true pathname of the tclkit, to work as a starpack or stardll.
*/
static int
TclKitPathObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
{
/*
* If we have a tclKitPath set, then set that to ::tcl::kitpath.
* This will be used instead of 'info nameofexecutable' for
* determining the location of the base kit. This is necessary
* for DLL-based starkits.
*/
char* str;
if (objc == 2) {
/*
* XXX: Should we allow people to set this?
*/
TclKit_SetKitPath(Tcl_GetString(objv[1]));
} else if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?path?");
}
str = tclKitPath ? tclKitPath : Tcl_GetNameOfExecutable();
Tcl_SetObjResult(interp, Tcl_NewStringObj(str, -1));
return TCL_OK;
}
/*
** This routine runs first.
*/
int main(int argc, char **argv){
Tcl_Interp *interp;
char *args;
char buf[100];
int tty;
char TCLdir[20];
char TKdir[20];
char autopath[20];
char sourceCmd[80];
#ifdef WITHOUT_TK
Tcl_Obj *resultPtr;
Tcl_Obj *commandPtr = NULL;
char buffer[1000];
int code, gotPartial, length;
Tcl_Channel inChannel, outChannel, errChannel;
#endif
/* Create a Tcl interpreter
*/
Tcl_FindExecutable(argv[0]);
interp = Tcl_CreateInterp();
if( Tcl_PkgRequire(interp, "Tcl", TCL_VERSION, 1)==0 ){
return 1;
}
args = Tcl_Merge(argc-1, (CONST84 char * CONST *)argv+1);
Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
ckfree(args);
sprintf(buf, "%d", argc-1);
Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY);
Tcl_SetVar(interp, "argv0", argv[0], TCL_GLOBAL_ONLY);
tty = isatty(0);
Tcl_SetVar(interp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
/* We have to initialize the virtual filesystem before calling
** Tcl_Init(). Otherwise, Tcl_Init() will not be able to find
** its startup script files.
*/
Zvfs_Init(interp);
Tcl_SetVar(interp, "extname", "", TCL_GLOBAL_ONLY);
Zvfs_Mount(interp, (char *)Tcl_GetNameOfExecutable(), "/");
sprintf(TCLdir, "%s/tcl", mountPt);
Tcl_SetVar2(interp, "env", "TCL_LIBRARY", TCLdir, TCL_GLOBAL_ONLY);
sprintf(TKdir, "%s/tk", mountPt);
Tcl_SetVar2(interp, "env", "TK_LIBRARY", TKdir, TCL_GLOBAL_ONLY);
/* Initialize Tcl and Tk
*/
if( Tcl_Init(interp) ) return TCL_ERROR;
sprintf(autopath, " %s", TCLdir);
Tcl_SetVar(interp, "auto_path", autopath, TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
Tcl_SetVar(interp, "tcl_libPath", TCLdir, TCL_GLOBAL_ONLY);
#ifdef WITHOUT_TK
Tcl_SetVar(interp, "extname", "tclsh", TCL_GLOBAL_ONLY);
#else
Tk_InitConsoleChannels(interp);
if ( Tk_Init(interp) ) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp,"Tk", Tk_Init, 0);
Tk_CreateConsoleWindow(interp);
#endif
/* Start up all extensions.
*/
#if defined(__WIN32__)
/* DRL - Do the standard Windows extentions */
if (Registry_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Registry", Registry_Init, 0);
if (Dde_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Dde", Dde_Init, 0);
#endif
#ifndef WITHOUT_TDOM
if (Tdom_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Tdom", Tdom_Init, Tdom_SafeInit);
#endif
#ifndef WITHOUT_TLS
if (Tls_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Tls", Tls_Init, Tls_SafeInit);
#endif
/*
#ifndef WITHOUT_MKZIPLIB
if (Mkziplib_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Mkziplib", Mkziplib_Init, Mkziplib_SafeInit);
#endif
*/
#ifndef WITHOUT_XOTCL
if (Xotcl_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Xotcl", Xotcl_Init, Xotcl_SafeInit);
/*
if (Xotclexpat_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "xotclexpat", Xotclexpat_Init, 0);
*/
/*
if (Xotclsdbm_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
*/
// Tcl_StaticPackage(interp, "xotclsdbm", Xotclsdbm_Init, Xotclsdbm_SafeInit);
/*
if (Xotclgdbm_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
*/
// Tcl_StaticPackage(interp, "xotclgdbm", Xotclgdbm_Init, Xotclgdbm_SafeInit);
#endif
#ifndef WITHOUT_TGDBM
if (Tgdbm_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Tgdbm", Tgdbm_Init, 0);
#endif
#ifndef WITHOUT_THREAD
if (Thread_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Thread", Thread_Init, 0);
#endif
#if !defined(WITHOUT_TK) && !defined(WITHOUT_WINICO) && (defined(__WIN32__) || defined(_WIN32))
if (Winico_Init(interp) == TCL_ERROR) return TCL_ERROR;
Tcl_StaticPackage(interp, "Winico", Winico_Init, Winico_SafeInit);
#endif
/* Add some freeWrap commands */
if (Freewrap_Init(interp) == TCL_ERROR) return TCL_ERROR;
/* After all extensions are registered, start up the
** program by running freewrapCmds.tcl.
*/
sprintf(sourceCmd, "source %s/freewrapCmds.tcl", mountPt);
Tcl_Eval(interp, sourceCmd);
#ifndef WITHOUT_TK
/*
* Loop infinitely, waiting for commands to execute. When there
* are no windows left, Tk_MainLoop returns and we exit.
*/
Tk_MainLoop();
Tcl_DeleteInterp(interp);
Tcl_Exit(0);
#else
/*
* Process commands from stdin until there's an end-of-file. Note
* that we need to fetch the standard channels again after every
* eval, since they may have been changed.
*/
commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
gotPartial = 0;
while (1) {
if (tty) {
Tcl_Obj *promptCmdPtr;
promptCmdPtr = Tcl_GetVar2Ex(interp,
(gotPartial ? "tcl_prompt2" : "tcl_prompt1"),
NULL, TCL_GLOBAL_ONLY);
if (promptCmdPtr == NULL) {
defaultPrompt:
if (!gotPartial && outChannel) {
Tcl_WriteChars(outChannel, "% ", 2);
}
} else {
code = Tcl_EvalObjEx(interp, promptCmdPtr, 0);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (code != TCL_OK) {
if (errChannel) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
Tcl_AddErrorInfo(interp,
"\n (script that generates prompt)");
goto defaultPrompt;
}
}
if (outChannel) {
Tcl_Flush(outChannel);
}
}
if (!inChannel) {
goto done;
}
length = Tcl_GetsObj(inChannel, commandPtr);
if (length < 0) {
goto done;
}
if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) {
goto done;
}
/*
* Add the newline removed by Tcl_GetsObj back to the string.
*/
Tcl_AppendToObj(commandPtr, "\n", 1);
if (!TclObjCommandComplete(commandPtr)) {
gotPartial = 1;
continue;
}
gotPartial = 0;
code = Tcl_RecordAndEvalObj(interp, commandPtr, 0);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
if (code != TCL_OK) {
if (errChannel) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
} else if (tty) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_GetStringFromObj(resultPtr, &length);
if ((length > 0) && outChannel) {
Tcl_WriteObj(outChannel, resultPtr);
Tcl_WriteChars(outChannel, "\n", 1);
}
}
}
/*
* Rather than calling exit, invoke the "exit" command so that
* users can replace "exit" with some other command to do additional
* cleanup on exit. The Tcl_Eval call should never return.
*/
done:
if (commandPtr != NULL) {
Tcl_DecrRefCount(commandPtr);
}
sprintf(buffer, "exit %d", 0);
Tcl_Eval(interp, buffer);
#endif
return TCL_OK;
}
