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"); }