void
TclpSetInitialEncodings(void)
{
Tcl_DString encodingName;
Tcl_SetSystemEncoding(NULL,
Tcl_GetEncodingNameFromEnvironment(&encodingName));
Tcl_DStringFree(&encodingName);
}
__declspec(dllexport) int
#else
extern int
#endif
TclKit_AppInit(Tcl_Interp *interp)
{
/*
* Ensure that std channels exist (creating them if necessary)
*/
TclKit_InitStdChannels();
#ifdef KIT_INCLUDES_ITCL
Tcl_StaticPackage(0, "Itcl", Itcl_Init, NULL);
#endif
#ifdef KIT_LITE
Tcl_StaticPackage(0, "vlerq", Vlerq_Init, Vlerq_SafeInit);
#else
Tcl_StaticPackage(0, "Mk4tcl", Mk4tcl_Init, NULL);
#endif
#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85
Tcl_StaticPackage(0, "pwb", Pwb_Init, NULL);
#endif
Tcl_StaticPackage(0, "tclkitpath", TclKitPath_Init, NULL);
Tcl_StaticPackage(0, "rechan", Rechan_Init, NULL);
Tcl_StaticPackage(0, "vfs", Vfs_Init, NULL);
#if KIT_INCLUDES_ZLIB
Tcl_StaticPackage(0, "zlib", Zlib_Init, NULL);
#endif
#ifdef TCL_THREADS
Tcl_StaticPackage(0, "Thread", Thread_Init, Thread_SafeInit);
#endif
#ifdef _WIN32
#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION > 84
Tcl_StaticPackage(0, "dde", Dde_Init, Dde_SafeInit);
#else
Tcl_StaticPackage(0, "dde", Dde_Init, NULL);
#endif
Tcl_StaticPackage(0, "registry", Registry_Init, NULL);
#endif
#ifdef KIT_INCLUDES_TK
Tcl_StaticPackage(0, "Tk", Tk_Init, Tk_SafeInit);
#endif
/* insert custom packages here */
/* the tcl_rcFileName variable only exists in the initial interpreter */
#ifdef _WIN32
Tcl_SetVar(interp, "tcl_rcFileName", "~/tclkitrc.tcl", TCL_GLOBAL_ONLY);
#else
Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclkitrc", TCL_GLOBAL_ONLY);
#endif
#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION > 84
{
Tcl_DString encodingName;
Tcl_GetEncodingNameFromEnvironment(&encodingName);
if (strcmp(Tcl_DStringValue(&encodingName), Tcl_GetEncodingName(NULL))) {
/* fails, so we set a variable and do it in the boot.tcl script */
Tcl_SetSystemEncoding(NULL, Tcl_DStringValue(&encodingName));
}
Tcl_SetVar(interp, "tclkit_system_encoding", Tcl_DStringValue(&encodingName), 0);
Tcl_DStringFree(&encodingName);
}
#endif
TclSetPreInitScript(preInitCmd);
if (Tcl_Init(interp) == TCL_ERROR)
goto error;
#if defined(KIT_INCLUDES_TK) && defined(_WIN32)
if (Tk_Init(interp) == TCL_ERROR)
goto error;
if (Tk_CreateConsoleWindow(interp) == TCL_ERROR)
goto error;
#endif
/* messy because TclSetStartupScriptPath is called slightly too late */
if (Tcl_EvalEx(interp, initScript, -1, TCL_EVAL_GLOBAL) == TCL_OK) {
const char *encoding = NULL;
Tcl_Obj* path = Tcl_GetStartupScript(&encoding);
Tcl_SetStartupScript(Tcl_GetObjResult(interp), encoding);
if (path == NULL) {
Tcl_Eval(interp, "incr argc -1; set argv [lrange $argv 1 end]");
}
}
Tcl_SetVar(interp, "errorInfo", "", TCL_GLOBAL_ONLY);
Tcl_ResetResult(interp);
return TCL_OK;
error:
#if defined(KIT_INCLUDES_TK) && defined(_WIN32)
MessageBeep(MB_ICONEXCLAMATION);
MessageBox(NULL, Tcl_GetStringResult(interp), "Error in Tclkit",
MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND);
ExitProcess(1);
/* we won't reach this, but we need the return */
#endif
return TCL_ERROR;
}
/*--------------------------------------------------------------------------*/
BOOL SetTclTkEnvironment(char *DefaultPath)
{
#define TCL_LIBRARY "TCL_LIBRARY"
#define TCL_LIBRARY_FORMAT "%s/modules/tclsci/tcl/tcl%d.%d"
#define TK_LIBRARY "TK_LIBRARY"
#define TK_LIBRARY_FORMAT "%s/modules/tclsci/tcl/tk%d.%d"
#define TCL_DEFAULT_ENCODING_DIR_FORMAT "%s/modules/tclsci/tcl/tcl%d.%d/encoding"
int tcl_major = 8;
int tcl_minor = 4; /* default */
int tcl_patchLevel = 0;
int tcl_type = 0;
BOOL bOK = TRUE;
char TCL_LIBRARY_PATH[PATH_MAX];
char TK_LIBRARY_PATH[PATH_MAX];
char TCL_DEFAULT_ENCODING_DIR[PATH_MAX];
Tcl_DString encodingName;
char ShortPath[PATH_MAX];
char *CopyOfDefaultPath = NULL;
Tcl_Obj *pathPtr = NULL;
Tcl_Obj *objPtr = NULL;
CopyOfDefaultPath = MALLOC(((int)strlen(DefaultPath) + 1) * sizeof(char));
if (CopyOfDefaultPath == NULL)
{
return FALSE;
}
if (getScilabMode() == SCILAB_STD)
{
/* redirect stdout, stderr in console */
freopen("CONOUT$", "wb", stdout); /* redirect stdout --> CONOUT$*/
freopen("CONOUT$", "wb", stderr); /* redirect stderr --> CONOUT$*/
}
Tcl_GetVersion(&tcl_major, &tcl_minor, &tcl_patchLevel, &tcl_type);
GetShortPathName(DefaultPath, ShortPath, PATH_MAX);
AntislashToSlash(ShortPath, CopyOfDefaultPath);
sprintf (TCL_LIBRARY_PATH, TCL_LIBRARY_FORMAT, CopyOfDefaultPath, tcl_major, tcl_minor);
sprintf (TK_LIBRARY_PATH, TK_LIBRARY_FORMAT, CopyOfDefaultPath, tcl_major, tcl_minor);
sprintf (TCL_DEFAULT_ENCODING_DIR,
TCL_DEFAULT_ENCODING_DIR_FORMAT,
CopyOfDefaultPath,
tcl_major,
tcl_minor);
if (CopyOfDefaultPath)
{
FREE(CopyOfDefaultPath);
CopyOfDefaultPath = NULL;
}
/* TCL_LIBRARY initialization */
SetEnvironmentVariable(TCL_LIBRARY, TCL_LIBRARY_PATH);
setenvtcl(TCL_LIBRARY, TCL_LIBRARY_PATH);
if (Tcl_SetVar(getTclInterp(), "tcl_library", TCL_LIBRARY_PATH, TCL_GLOBAL_ONLY) == NULL)
{
releaseTclInterp();
fprintf(stderr, _("%s: An error occurred: %s\n"), "tcl_library",
_("Impossible to set environment variable."));
bOK = FALSE;
}
releaseTclInterp();
if (Tcl_SetVar(getTclInterp(), "tclDefaultLibrary", TCL_LIBRARY_PATH, TCL_GLOBAL_ONLY) == NULL)
{
releaseTclInterp();
fprintf(stderr, _("%s: An error occurred: %s\n"), "tclDefaultLibrary",
_("Impossible to set environment variable."));
bOK = FALSE;
}
releaseTclInterp();
if (Tcl_SetVar(getTclInterp(), "tcl_pkgPath", TCL_LIBRARY_PATH, TCL_GLOBAL_ONLY) == NULL)
{
releaseTclInterp();
fprintf(stderr, _("%s: An error occurred: %s\n"), "tcl_pkgPath",
_("Impossible to set environment variable."));
bOK = FALSE;
}
releaseTclInterp();
pathPtr = Tcl_NewStringObj(TCL_LIBRARY_PATH, -1);
/* TK_LIBRARY initialization */
SetEnvironmentVariable(TK_LIBRARY, TK_LIBRARY_PATH);
setenvtcl(TK_LIBRARY, TK_LIBRARY_PATH);
if (Tcl_SetVar(getTclInterp(), "tk_library", TK_LIBRARY_PATH, TCL_GLOBAL_ONLY) == NULL)
{
releaseTclInterp();
fprintf(stderr, _("%s: An error occurred: %s\n"), "tk_library",
_("Impossible to set environment variable."));
bOK = FALSE;
}
releaseTclInterp();
objPtr = Tcl_NewStringObj(TK_LIBRARY_PATH, -1);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
TclSetLibraryPath(pathPtr);
/* encoding initialization */
Tcl_SetDefaultEncodingDir(TCL_DEFAULT_ENCODING_DIR);
if ( Tcl_SetSystemEncoding(NULL, Tcl_GetEncodingNameFromEnvironment(&encodingName)) == TCL_ERROR )
{
fprintf(stderr, _("%s: An error occurred: %s\n"), "Tcl_SetSystemEncoding",
_("Impossible to set system encoding."));
bOK = FALSE;
}
Tcl_DStringFree(&encodingName);
return bOK ;
}
void Init(CCore* Root) {
const char * const *argv;
CModuleImplementation::Init(Root);
g_Bouncer = Root;
const char *ConfigFile = g_Bouncer->BuildPathConfig("sbnc.tcl");
struct stat statbuf;
if (stat(ConfigFile, &statbuf) < 0) {
FILE *ConfigFd = fopen(ConfigFile, "wb");
if (ConfigFd == NULL) {
g_Bouncer->Log("Could not create 'sbnc.tcl' file.");
g_Bouncer->Fatal();
}
const char *ConfigDistFile = g_Bouncer->BuildPathShared("scripts/sbnc.tcl.dist");
FILE *ConfigDistFd = fopen(ConfigDistFile, "rb");
if (ConfigDistFd == NULL) {
ConfigFile = g_Bouncer->BuildPathConfig("sbnc.tcl");
unlink(ConfigFile);
g_Bouncer->Log("Could not open 'sbnc.tcl.dist' file.");
g_Bouncer->Fatal();
}
while (!feof(ConfigDistFd) && !ferror(ConfigDistFd)) {
size_t Count;
char Buffer[1024];
Count = fread(Buffer, 1, sizeof(Buffer), ConfigDistFd);
if (fwrite(Buffer, 1, Count, ConfigFd) < Count) {
g_Bouncer->Log("Could not write to 'sbnc.tcl' file.");
g_Bouncer->Fatal();
}
}
fclose(ConfigDistFd);
fclose(ConfigFd);
}
const char *ScriptsDir = g_Bouncer->BuildPathConfig("scripts");
if (mkdir(ScriptsDir) < 0 && errno != EEXIST) {
g_Bouncer->Log("Could not create 'scripts' directory.");
g_Bouncer->Fatal();
}
g_TclListeners = new CHashtable<CTclSocket*, false>();
g_TclClientSockets = new CHashtable<CTclClientSocket*, false>();
argv = GetCore()->GetArgV();
Tcl_FindExecutable(argv[0]);
Tcl_SetSystemEncoding(NULL, "ISO8859-1");
g_Encoding = Tcl_GetEncoding(g_Interp, "ISO8859-1");
g_Interp = Tcl_CreateInterp();
Tcl_InitMemory(g_Interp);
Tcl_SetVar(g_Interp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
Tcl_AppInit(g_Interp);
Tcl_Preserve(g_Interp);
Tcl_Eval(g_Interp,
"rename source tcl_source\n"
"\n"
"# TODO: add support for -rsrc and -rsrcid\n"
"proc source {args} {\n"
" set file [lindex $args end]\n"
"\n"
" set has_shared_file [file isfile [file join [bncshareddir] $file]]\n"
" set has_user_file [file isfile [file join [bncconfigdir] $file]]\n"
"\n"
" if {!$has_user_file && $has_shared_file} {\n"
" set file [file join [bncshareddir] $file]\n"
" }\n"
"\n"
" uplevel 1 tcl_source [lreplace $args end end $file]\n"
"}");
Tcl_EvalFile(g_Interp, "./sbnc.tcl");
}
