static void
InitNotifier(void)
{
initialized = 1;
memset(¬ifier, 0, sizeof(notifier));
Tcl_CreateExitHandler(NotifierExitHandler, NULL);
}
void
InitNotifier(void)
{
Tcl_NotifierProcs notifier;
/*
* Only reinitialize if we are not in exit handling. The notifier can get
* reinitialized after its own exit handler has run, because of exit
* handlers for the I/O and timer sub-systems (order dependency).
*/
if (TclInExit()) {
return;
}
notifier.createFileHandlerProc = CreateFileHandler;
notifier.deleteFileHandlerProc = DeleteFileHandler;
notifier.setTimerProc = SetTimer;
notifier.waitForEventProc = WaitForEvent;
Tcl_SetNotifier(¬ifier);
/*
* DO NOT create the application context yet; doing so would prevent
* external applications from setting it for us to their own ones.
*/
initialized = 1;
memset(¬ifier, 0, sizeof(notifier));
Tcl_CreateExitHandler(NotifierExitHandler, NULL);
}
static void
ConsoleInit(void)
{
ThreadSpecificData *tsdPtr;
/*
* Check the initialized flag first, then check again in the mutex. This
* is a speed enhancement.
*/
if (!initialized) {
Tcl_MutexLock(&consoleMutex);
if (!initialized) {
initialized = 1;
Tcl_CreateExitHandler(ProcExitHandler, NULL);
}
Tcl_MutexUnlock(&consoleMutex);
}
tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
tsdPtr->firstConsolePtr = NULL;
Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL);
Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL);
}
}
HandleNameToRepMap::HandleNameToRepMap (Tcl_Interp *interp):
m_interp(interp)
{
Tcl_InitHashTable(&m_handleMap, TCL_STRING_KEYS);
Tcl_SetAssocData(interp, ASSOC_KEY, deleteInterpProc, this);
Tcl_CreateExitHandler(exitProc, this);
}
void
TkCreateXEventSource()
{
if (!initialized) {
initialized = 1;
Tcl_CreateEventSource(DisplaySetupProc, DisplayCheckProc, NULL);
Tcl_CreateExitHandler(DisplayExitHandler, NULL);
}
}
void shell_run(tree_t e, struct tree_rd_ctx *ctx)
{
const int ndecls = tree_decls(e);
hash_t *decl_hash = hash_new(ndecls * 2, true);
for (int i = 0; i < ndecls; i++) {
tree_t d = tree_decl(e, i);
hash_put(decl_hash, tree_ident(d), d);
}
Tcl_Interp *interp = Tcl_CreateInterp();
bool have_quit = false;
Tcl_CreateExitHandler(shell_exit_handler, &have_quit);
shell_cmd_t shell_cmds[] = {
CMD(quit, &have_quit, "Exit simulation"),
CMD(run, ctx, "Start or resume simulation"),
CMD(restart, NULL, "Restart simulation"),
CMD(show, decl_hash, "Display simulation objects"),
CMD(help, shell_cmds, "Display this message"),
CMD(copyright, NULL, "Display copyright information"),
CMD(signals, e, "Find signal objects in the design"),
CMD(now, NULL, "Display current simulation time"),
CMD(watch, decl_hash, "Trace changes to a signal"),
CMD(unwatch, decl_hash, "Stop tracing signals"),
{ NULL, NULL, NULL, NULL}
};
qsort(shell_cmds, ARRAY_LEN(shell_cmds) - 1, sizeof(shell_cmd_t),
compare_shell_cmd);
for (shell_cmd_t *c = shell_cmds; c->name != NULL; c++)
Tcl_CreateObjCommand(interp, c->name, c->fn, c->cd, NULL);
show_banner();
slave_post_msg(SLAVE_RESTART, NULL, 0);
char *line;
while (!have_quit && (line = shell_get_line())) {
switch (Tcl_Eval(interp, line)) {
case TCL_OK:
break;
case TCL_ERROR:
errorf("%s", Tcl_GetStringResult(interp));
break;
default:
assert(false);
}
free(line);
}
Tcl_Exit(EXIT_SUCCESS);
}
void RtclProxyBase::CreateObjectCmd(Tcl_Interp* interp, const char* name)
{
fInterp = interp;
fCmdToken =
Tcl_CreateObjCommand(interp, name, ThunkTclObjectCmd, (ClientData) this,
(Tcl_CmdDeleteProc *) ThunkTclCmdDeleteProc);
RtclContext::Find(interp).RegisterProxy(this);
Tcl_CreateExitHandler((Tcl_ExitProc*) ThunkTclExitProc, (ClientData) this);
return;
}
ObjToRepMap::ObjToRepMap ()
{
Tcl_InitHashTable(&m_objMap, TCL_ONE_WORD_KEYS);
#ifdef TCL_THREADS
Tcl_CreateThreadExitHandler(exitProc, this);
#else
Tcl_CreateExitHandler(exitProc, 0);
#endif
}
void NS(MqDumpS_New) (
Tcl_Interp * interp,
struct MqDumpS * dump
)
{
char buffer[30];
sprintf(buffer, "<MqDumpS-%p>", dump);
Tcl_CreateObjCommand (interp, buffer, NS(MqDumpS_Cmd), dump, NS(MqDumpS_Free));
Tcl_SetResult (interp, buffer, TCL_VOLATILE);
Tcl_CreateExitHandler (NS(MqDumpS_Free), dump);
}
static void
InitTimer()
{
initialized = 1;
lastTimerId = 0;
timerPending = 0;
idleGeneration = 0;
firstTimerHandlerPtr = NULL;
lastIdlePtr = NULL;
idleList = NULL;
Tcl_CreateEventSource(TimerSetupProc, TimerCheckProc, NULL);
Tcl_CreateExitHandler(TimerExitProc, NULL);
}
int appinit(Tcl_Interp *interp)
{
if (Tcl_Init(interp) == TCL_ERROR)
return (TCL_ERROR);
Tcl_CreateExitHandler(exitHandler, 0);
#ifdef TK
if (Tk_Init(interp) == TCL_ERROR)
return (TCL_ERROR);
#endif
if (on_program_start(interp) == TCL_ERROR)
return (TCL_ERROR);
return (TCL_OK);
}
/* these are the tcl init/exit routines */
int DLLEXPORT Br_Init(Tcl_Interp *interp)
{
/* initialize stubs and create the exit handler */
if( !Tcl_InitStubs(interp, TCL_VERSION, 0) )
return TCL_ERROR;
Tcl_CreateExitHandler(Br_Atexit, NULL);
/* prepare environment and load functions into tcl */
init_brick();
load_routines(interp);
return TCL_OK;
}
//------------------------------------------+-----------------------------------
//! FIXME_docs
bool RtclSignalAction::Init(Tcl_Interp* interp, RerrMsg& emsg)
{
if (fpObj) {
emsg.Init("RtclSignalAction::Init", "already initialized");
return false;
}
try {
fpObj = new RtclSignalAction(interp);
} catch (exception& e) {
emsg.Init("RtclSignalAction::Init", string("exception: ")+e.what());
return false;
}
Tcl_CreateExitHandler((Tcl_ExitProc*) ThunkTclExitProc, (ClientData) fpObj);
return true;
}
////////////////////////////////////////////////////
// Function to initialize register related stuff
////////////////////////////////////////////////////
int Register_Init(
Tcl_Interp *interp
) {
// initialize the hash table
Tcl_InitHashTable(®isterRegistrations, TCL_STRING_KEYS);
// register our commands
Tcl_CreateObjCommand(
interp, "::bonjour::register", bonjour_register,
®isterRegistrations, NULL
);
// create an exit handler for cleanup
Tcl_CreateExitHandler(
(Tcl_ExitProc *)bonjour_register_cleanup,
®isterRegistrations
);
return TCL_OK;
}
void *dlopen(
const char *path,
int mode
) {
void *handle;
LibraryList *ptr;
static int initialized = 0;
if (!initialized) {
initialized = 1;
Tcl_CreateExitHandler((Tcl_ExitProc *) UnloadLibraries,
(ClientData) &libraryList);
}
handle = (void *) LoadLibrary(path);
if (handle != NULL) {
ptr = (LibraryList*) ckalloc(sizeof(LibraryList));
ptr->handle = (HINSTANCE) handle;
ptr->nextPtr = libraryList;
libraryList = ptr;
}
return handle;
}
int
TnmIcmp(Tcl_Interp *interp, TnmIcmpRequest *icmpPtr)
{
static HANDLE hIcmp = 0; /* The handle for ICMP.DLL. */
int j, i, code;
DWORD nCount, dwStatus;
HANDLE *lpHandles;
if (! hIcmp) {
hIcmp = LoadLibrary("ICMP.DLL");
if (hIcmp) {
Tcl_CreateExitHandler(IcmpExit, hIcmp);
(FARPROC) pIcmpCreateFile
= (FARPROC) GetProcAddress(hIcmp, "IcmpCreateFile");
(FARPROC) pIcmpCloseHandle
= (FARPROC) GetProcAddress(hIcmp, "IcmpCloseHandle");
(FARPROC) pIcmpSendEcho
= (FARPROC) GetProcAddress(hIcmp, "IcmpSendEcho");
if (! pIcmpCreateFile || ! pIcmpCloseHandle || ! pIcmpSendEcho) {
FreeLibrary(hIcmp);
hIcmp = 0;
}
}
}
if (! hIcmp) {
Tcl_SetResult(interp, "failed to load ICMP.DLL", TCL_STATIC);
return TCL_ERROR;
}
hIP = pIcmpCreateFile();
if (hIP == INVALID_HANDLE_VALUE) {
Tcl_SetResult(interp, "failed to access ICMP.DLL", TCL_STATIC);
return TCL_ERROR;
}
/*
* Create a thread for every single target.
*/
lpHandles = (HANDLE *) ckalloc(icmpPtr->numTargets * sizeof(HANDLE));
code = TCL_OK;
j = 0;
while (j < icmpPtr->numTargets) {
for (i = j, nCount = 0;
i < icmpPtr->numTargets && nCount < 200
&& (! icmpPtr->window || (int) nCount < icmpPtr->window);
i++, nCount++) {
DWORD dwThreadId;
TnmIcmpTarget *targetPtr = &(icmpPtr->targets[i]);
IcmpThreadParam *threadParamPtr =
(IcmpThreadParam *) ckalloc(sizeof(IcmpThreadParam));
threadParamPtr->icmpPtr = icmpPtr;
threadParamPtr->targetPtr = targetPtr;
lpHandles[i] = CreateThread(NULL, 0,
(LPTHREAD_START_ROUTINE) IcmpThread,
(LPDWORD) threadParamPtr, 0,
&dwThreadId);
if (! lpHandles[i]) {
Tcl_ResetResult(interp);
Tcl_SetResult(interp, "failed to create ICMP thread",
TCL_STATIC);
code = TCL_ERROR;
break;
}
}
/*
* Wait here until all threads have finished, release the handles,
* free the handle array and finally move on.
*/
dwStatus = WaitForMultipleObjects(nCount, lpHandles+j, TRUE, INFINITE);
if (dwStatus == WAIT_FAILED) {
Tcl_ResetResult(interp);
Tcl_SetResult(interp, "failed to wait for ICMP thread",
TCL_STATIC);
code = TCL_ERROR;
}
for (i = j; nCount-- > 0; i++, j++) {
if (lpHandles[i]) {
CloseHandle(lpHandles[i]);
}
}
}
ckfree((char *) lpHandles);
pIcmpCloseHandle(hIP);
return code;
}
/*
* Nxhelper_Init
*
* Initialises the extension for a regular interpreter.
*
* Arguments:
* interp - Current interpreter.
*
* Returns:
* A standard Tcl result.
*/
int
Nxhelper_Init(
Tcl_Interp *interp
)
{
/* Wide integer support was added in Tcl 8.4. */
if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
return TCL_ERROR;
}
if (Tcl_PkgProvide(interp, PACKAGE_NAME, PACKAGE_VERSION) != TCL_OK) {
return TCL_ERROR;
}
/*
* Check if the library is already initialised before locking
* the global initialisation mutex (improves loading time).
*/
if (!initialised) {
Tcl_MutexLock(&initMutex);
/* Check initialisation status again now that we're in the mutex. */
if (!initialised) {
/* Initialise the OS version structure. */
osVersion.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
GetVersionEx(&osVersion);
kernelModule = LoadLibrary(TEXT("kernel32.dll"));
if (kernelModule != NULL) {
/*
* GetDiskFreeSpaceEx() must be resolved on run-time for backwards
* compatibility on older Windows systems (earlier than NT v5).
*/
#ifdef UNICODE
getDiskFreeSpaceExPtr = (Fn_GetDiskFreeSpaceEx)
GetProcAddress(kernelModule, "GetDiskFreeSpaceExW");
#else /* UNICODE */
getDiskFreeSpaceExPtr = (Fn_GetDiskFreeSpaceEx)
GetProcAddress(kernelModule, "GetDiskFreeSpaceExA");
#endif /* UNICODE */
}
/*
* If GetVolumeInformation() is called on a floppy drive or a CD-ROM drive
* that does not have a disk inserted, the system will display a message box
* asking the user to insert one.
*/
SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS);
/* An exit handler should be registered once. */
Tcl_CreateExitHandler(ExitHandler, NULL);
initialised = TRUE;
}
Tcl_MutexUnlock(&initMutex);
}
/* Create the hash table used for the "::nx::key" command. */
if (keyTable == NULL) {
Tcl_MutexLock(&keyMutex);
/* Check again now that we're in the mutex. */
if (keyTable == NULL) {
keyTable = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(keyTable, TCL_STRING_KEYS);
}
Tcl_MutexUnlock(&keyMutex);
}
Tcl_CreateObjCommand(interp, "::nx::base64", Base64ObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "::nx::key", KeyObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "::nx::mp3", Mp3ObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "::nx::sleep", SleepObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "::nx::time", TimeObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "::nx::touch", TouchObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "::nx::volume", VolumeObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "::nx::zlib", ZlibObjCmd, NULL, NULL);
return TCL_OK;
}
void
Tcl_MainEx(
int argc, /* Number of arguments. */
TCHAR **argv, /* Array of argument strings. */
Tcl_AppInitProc *appInitProc,
/* Application-specific initialization
* function to call after most initialization
* but before starting to execute commands. */
Tcl_Interp *interp)
{
Tcl_Obj *path, *resultPtr, *argvPtr, *appName;
const char *encodingName = NULL;
int code, exitCode = 0;
Tcl_MainLoopProc *mainLoopProc;
Tcl_Channel chan;
InteractiveState is;
TclpSetInitialEncodings();
TclpFindExecutable((const char *)argv[0]);
Tcl_InitMemory(interp);
is.interp = interp;
is.prompt = PROMPT_START;
is.commandPtr = Tcl_NewObj();
/*
* If the application has not already set a startup script, parse the
* first few command line arguments to determine the script path and
* encoding.
*/
if (NULL == Tcl_GetStartupScript(NULL)) {
/*
* Check whether first 3 args (argv[1] - argv[3]) look like
* -encoding ENCODING FILENAME
* or like
* FILENAME
*/
if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& ('-' != argv[3][0])) {
Tcl_Obj *value = NewNativeObj(argv[2], -1);
Tcl_SetStartupScript(NewNativeObj(argv[3], -1),
Tcl_GetString(value));
Tcl_DecrRefCount(value);
argc -= 3;
argv += 3;
} else if ((argc > 1) && ('-' != argv[1][0])) {
Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL);
argc--;
argv++;
}
}
path = Tcl_GetStartupScript(&encodingName);
if (path == NULL) {
appName = NewNativeObj(argv[0], -1);
} else {
appName = path;
}
Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY);
argc--;
argv++;
Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++, -1));
}
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
/*
* Set the "tcl_interactive" variable.
*/
is.tty = isatty(0);
Tcl_SetVar2Ex(interp, "tcl_interactive", NULL,
Tcl_NewIntObj(!path && is.tty), TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
Tcl_Preserve(interp);
if (appInitProc(interp) != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_WriteChars(chan,
"application-specific initialization failed: ", -1);
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
}
if (Tcl_InterpDeleted(interp)) {
goto done;
}
if (Tcl_LimitExceeded(interp)) {
goto done;
}
if (TclFullFinalizationRequested()) {
/*
* Arrange for final deletion of the main interp
*/
/* ARGH Munchhausen effect */
Tcl_CreateExitHandler(FreeMainInterp, interp);
}
/*
* Invoke the script specified on the command line, if any. Must fetch it
* again, as the appInitProc might have reset it.
*/
path = Tcl_GetStartupScript(&encodingName);
if (path != NULL) {
Tcl_ResetResult(interp);
code = Tcl_FSEvalFileEx(interp, path, encodingName);
if (code != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
Tcl_Obj *keyPtr, *valuePtr;
TclNewLiteralStringObj(keyPtr, "-errorinfo");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
if (valuePtr) {
Tcl_WriteObj(chan, valuePtr);
}
Tcl_WriteChars(chan, "\n", 1);
Tcl_DecrRefCount(options);
}
exitCode = 1;
}
goto done;
}
/*
* We're running interactively. Source a user-specific startup file if the
* application specified one and if the file exists.
*/
Tcl_SourceRCFile(interp);
if (Tcl_LimitExceeded(interp)) {
goto done;
}
/*
* 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.
*/
Tcl_IncrRefCount(is.commandPtr);
/*
* Get a new value for tty if anyone writes to ::tcl_interactive
*/
Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN);
is.input = Tcl_GetStdChannel(TCL_STDIN);
while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) {
mainLoopProc = TclGetMainLoop();
if (mainLoopProc == NULL) {
int length;
if (is.tty) {
Prompt(interp, &is);
if (Tcl_InterpDeleted(interp)) {
break;
}
if (Tcl_LimitExceeded(interp)) {
break;
}
is.input = Tcl_GetStdChannel(TCL_STDIN);
if (is.input == NULL) {
break;
}
}
if (Tcl_IsShared(is.commandPtr)) {
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
Tcl_IncrRefCount(is.commandPtr);
}
length = Tcl_GetsObj(is.input, is.commandPtr);
if (length < 0) {
if (Tcl_InputBlocked(is.input)) {
/*
* This can only happen if stdin has been set to
* non-blocking. In that case cycle back and try again.
* This sets up a tight polling loop (since we have no
* event loop running). If this causes bad CPU hogging, we
* might try toggling the blocking on stdin instead.
*/
continue;
}
/*
* Either EOF, or an error on stdin; we're done
*/
break;
}
/*
* Add the newline removed by Tcl_GetsObj back to the string. Have
* to add it back before testing completeness, because it can make
* a difference. [Bug 1775878]
*/
if (Tcl_IsShared(is.commandPtr)) {
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
Tcl_IncrRefCount(is.commandPtr);
}
Tcl_AppendToObj(is.commandPtr, "\n", 1);
if (!TclObjCommandComplete(is.commandPtr)) {
is.prompt = PROMPT_CONTINUE;
continue;
}
is.prompt = PROMPT_START;
/*
* The final newline is syntactically redundant, and causes some
* error messages troubles deeper in, so lop it back off.
*/
Tcl_GetStringFromObj(is.commandPtr, &length);
Tcl_SetObjLength(is.commandPtr, --length);
code = Tcl_RecordAndEvalObj(interp, is.commandPtr,
TCL_EVAL_GLOBAL);
is.input = Tcl_GetStdChannel(TCL_STDIN);
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(is.commandPtr);
if (code != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
} else if (is.tty) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultPtr);
Tcl_GetStringFromObj(resultPtr, &length);
chan = Tcl_GetStdChannel(TCL_STDOUT);
if ((length > 0) && chan) {
Tcl_WriteObj(chan, resultPtr);
Tcl_WriteChars(chan, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
} else { /* (mainLoopProc != NULL) */
/*
* If a main loop has been defined while running interactively, we
* want to start a fileevent based prompt by establishing a
* channel handler for stdin.
*/
if (is.input) {
if (is.tty) {
Prompt(interp, &is);
}
Tcl_CreateChannelHandler(is.input, TCL_READABLE,
StdinProc, &is);
}
mainLoopProc();
Tcl_SetMainLoop(NULL);
if (is.input) {
Tcl_DeleteChannelHandler(is.input, StdinProc, &is);
}
is.input = Tcl_GetStdChannel(TCL_STDIN);
}
/*
* This code here only for the (unsupported and deprecated) [checkmem]
* command.
*/
#ifdef TCL_MEM_DEBUG
if (tclMemDumpFileName != NULL) {
Tcl_SetMainLoop(NULL);
Tcl_DeleteInterp(interp);
}
#endif /* TCL_MEM_DEBUG */
}
done:
mainLoopProc = TclGetMainLoop();
if ((exitCode == 0) && mainLoopProc && !Tcl_LimitExceeded(interp)) {
/*
* If everything has gone OK so far, call the main loop proc, if it
* exists. Packages (like Tk) can set it to start processing events at
* this point.
*/
mainLoopProc();
Tcl_SetMainLoop(NULL);
}
if (is.commandPtr != NULL) {
Tcl_DecrRefCount(is.commandPtr);
}
/*
* 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_EvalObjEx call should never return.
*/
if (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) {
Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode);
Tcl_IncrRefCount(cmd);
Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmd);
}
/*
* If Tcl_EvalObjEx returns, trying to eval [exit], something unusual is
* happening. Maybe interp has been deleted; maybe [exit] was redefined,
* maybe we've blown up because of an exceeded limit. We still want to
* cleanup and exit.
*/
Tcl_Exit(exitCode);
}
/*++
Alcoext_Init
Initialises the extension for a regular interpreter.
Arguments:
interp - Current interpreter.
Return Value:
A standard Tcl result.
--*/
int
Alcoext_Init(
Tcl_Interp *interp
)
{
ExtState *statePtr;
StateList *stateListPtr;
// Wide integer support was added in Tcl 8.4.
#ifdef USE_TCL_STUBS
if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
return TCL_ERROR;
}
#else // USE_TCL_STUBS
if (Tcl_PkgRequire(interp, "Tcl", "8.4", 0) == NULL) {
return TCL_ERROR;
}
#endif // USE_TCL_STUBS
if (Tcl_PkgProvide(interp, PACKAGE_NAME, PACKAGE_VERSION) != TCL_OK) {
return TCL_ERROR;
}
//
// Check if the library is already initialised before locking
// the global initialisation mutex (improves loading time).
//
if (!initialised) {
Tcl_MutexLock(&initMutex);
// Check initialisation status again now that we're in the mutex.
if (!initialised) {
#ifdef _WINDOWS
// Initialise the OS version structure.
osVersion.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
GetVersionExA(&osVersion);
ZeroMemory(&winProcs, sizeof(WinProcs));
winProcs.module = LoadLibraryA("kernel32.dll");
if (winProcs.module != NULL) {
//
// These functions must be resolved on run-time for backwards
// compatibility on older Windows systems (earlier than NT v5).
//
winProcs.getDiskFreeSpaceEx = (GetDiskFreeSpaceExProc)
GetProcAddress(winProcs.module, "GetDiskFreeSpaceExA");
winProcs.findFirstVolumeMountPoint = (FindFirstVolumeMountPointProc)
GetProcAddress(winProcs.module, "FindFirstVolumeMountPointA");
winProcs.findNextVolumeMountPoint = (FindNextVolumeMountPointProc)
GetProcAddress(winProcs.module, "FindNextVolumeMountPointA");
winProcs.findVolumeMountPointClose = (FindVolumeMountPointCloseProc)
GetProcAddress(winProcs.module, "FindVolumeMountPointClose");
winProcs.getVolumeNameForVolumeMountPoint = (GetVolumeNameForVolumeMountPointProc)
GetProcAddress(winProcs.module, "GetVolumeNameForVolumeMountPointA");
}
//
// If GetVolumeInformation() is called on a floppy drive or a CD-ROM
// drive that does not have a disk inserted, the system will display
// a message box asking the user to insert one.
//
SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS);
#endif // _WINDOWS
// An exit handler must only be registered once.
Tcl_CreateExitHandler(ExitHandler, NULL);
// Register ciphers, hashes, and PRNGs for LibTomCrypt.
register_cipher(&des3_desc);
register_cipher(&aes_desc);
register_cipher(&anubis_desc);
register_cipher(&blowfish_desc);
register_cipher(&cast5_desc);
register_cipher(&des_desc);
register_cipher(&khazad_desc);
register_cipher(&noekeon_desc);
register_cipher(&rc2_desc);
register_cipher(&rc5_desc);
register_cipher(&rc6_desc);
register_cipher(&saferp_desc);
register_cipher(&safer_k128_desc);
register_cipher(&safer_k64_desc);
register_cipher(&safer_sk128_desc);
register_cipher(&safer_sk64_desc);
register_cipher(&skipjack_desc);
register_cipher(&twofish_desc);
register_cipher(&xtea_desc);
register_hash(&md2_desc);
register_hash(&md4_desc);
register_hash(&md5_desc);
register_hash(&rmd128_desc);
register_hash(&rmd160_desc);
register_hash(&sha1_desc);
register_hash(&sha224_desc);
register_hash(&sha256_desc);
register_hash(&sha384_desc);
register_hash(&sha512_desc);
register_hash(&tiger_desc);
register_hash(&whirlpool_desc);
register_prng(&fortuna_desc);
register_prng(&rc4_desc);
register_prng(&sober128_desc);
register_prng(&sprng_desc);
register_prng(&yarrow_desc);
initialised = 1;
}
Tcl_MutexUnlock(&initMutex);
}
// Allocate state structures.
stateListPtr = (StateList *)ckalloc(sizeof(StateList));
statePtr = (ExtState *)ckalloc(sizeof(ExtState));
statePtr->cryptTable = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(statePtr->cryptTable, TCL_STRING_KEYS);
#ifndef _WINDOWS
statePtr->glftpdTable = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(statePtr->glftpdTable, TCL_STRING_KEYS);
#endif // !_WINDOWS
//
// Since callbacks registered with Tcl_CallWhenDeleted() are not executed in
// certain situations (calling Tcl_Finalize() or invoking the "exit" command),
// these resources must be freed by an exit handler registered with
// Tcl_CreateExitHandler().
//
stateListPtr->interp = interp;
stateListPtr->state = statePtr;
stateListPtr->next = NULL;
stateListPtr->prev = NULL;
Tcl_MutexLock(&stateMutex);
// Insert at the list head.
if (stateListHead == NULL) {
stateListHead = stateListPtr;
} else {
stateListPtr->next = stateListHead;
stateListHead->prev = stateListPtr;
stateListHead = stateListPtr;
}
Tcl_MutexUnlock(&stateMutex);
// Clean up state on interpreter deletion.
Tcl_CallWhenDeleted(interp, InterpDeleteHandler, (ClientData)statePtr);
// Create Tcl commands.
Tcl_CreateObjCommand(interp, "::alcoholicz::compress", CompressObjCmd,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
Tcl_CreateObjCommand(interp, "::alcoholicz::crypt", CryptObjCmd,
(ClientData)statePtr, (Tcl_CmdDeleteProc *)NULL);
Tcl_CreateObjCommand(interp, "::alcoholicz::decode", EncodingObjCmd,
(ClientData)decodeFuncts, (Tcl_CmdDeleteProc *)NULL);
Tcl_CreateObjCommand(interp, "::alcoholicz::encode", EncodingObjCmd,
(ClientData)encodeFuncts, (Tcl_CmdDeleteProc *)NULL);
//
// These commands are not created for safe interpreters because
// they interact with the file system and/or other processes.
//
if (!Tcl_IsSafe(interp)) {
Tcl_CreateObjCommand(interp, "::alcoholicz::volume", VolumeObjCmd,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
#ifdef _WINDOWS
Tcl_CreateObjCommand(interp, "::alcoholicz::ioftpd", IoFtpdObjCmd,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
#else // _WINDOWS
Tcl_CreateObjCommand(interp, "::alcoholicz::glftpd", GlFtpdObjCmd,
(ClientData)statePtr, (Tcl_CmdDeleteProc *)NULL);
#endif // _WINDOWS
}
Tcl_Eval(interp, "namespace eval ::alcoholicz {"
"namespace export compress crypt encode decode volume "
#ifdef _WINDOWS
"ioftpd"
#else
"glftpd"
#endif // _WINDOWS
"}"
);
return TCL_OK;
}
/*++
Initialise
Initialises the library; allocating and registering resources.
Arguments:
None.
Return Value:
None.
--*/
static void
Initialise(
void
)
{
DebugPrint("Initialise: initialised=%d\n", initialised);
//
// Check if the library is already initialised before locking
// the global initialisation mutex (improves loading time).
//
if (initialised) {
return;
}
Tcl_MutexLock(&initMutex);
// Check initialisation status again now that we are in the mutex.
if (!initialised) {
#ifdef _WINDOWS
// Initialise the OS version structure.
osVersion.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
GetVersionExA(&osVersion);
ZeroMemory(&winProcs, sizeof(WinProcs));
winProcs.module = LoadLibraryA("kernel32.dll");
if (winProcs.module != NULL) {
//
// These functions must be resolved on run-time for backwards
// compatibility on older Windows systems (earlier than NT v5).
//
winProcs.getDiskFreeSpaceEx = (GetDiskFreeSpaceExProc)
GetProcAddress(winProcs.module, "GetDiskFreeSpaceExA");
winProcs.findFirstVolumeMountPoint = (FindFirstVolumeMountPointProc)
GetProcAddress(winProcs.module, "FindFirstVolumeMountPointA");
winProcs.findNextVolumeMountPoint = (FindNextVolumeMountPointProc)
GetProcAddress(winProcs.module, "FindNextVolumeMountPointA");
winProcs.findVolumeMountPointClose = (FindVolumeMountPointCloseProc)
GetProcAddress(winProcs.module, "FindVolumeMountPointClose");
winProcs.getVolumeNameForVolumeMountPoint = (GetVolumeNameForVolumeMountPointProc)
GetProcAddress(winProcs.module, "GetVolumeNameForVolumeMountPointA");
}
//
// If GetVolumeInformation() is called on a floppy drive or a CD-ROM
// drive that does not have a disk inserted, the system will display
// a message box asking the user to insert one.
//
SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS);
#endif // _WINDOWS
// Register ciphers, hashes, and PRNGs for LibTomCrypt.
register_cipher(&des3_desc);
register_cipher(&aes_desc);
register_cipher(&anubis_desc);
register_cipher(&blowfish_desc);
register_cipher(&cast5_desc);
register_cipher(&des_desc);
register_cipher(&khazad_desc);
register_cipher(&noekeon_desc);
register_cipher(&rc2_desc);
register_cipher(&rc5_desc);
register_cipher(&rc6_desc);
register_cipher(&saferp_desc);
register_cipher(&safer_k128_desc);
register_cipher(&safer_k64_desc);
register_cipher(&safer_sk128_desc);
register_cipher(&safer_sk64_desc);
register_cipher(&skipjack_desc);
register_cipher(&twofish_desc);
register_cipher(&xtea_desc);
register_hash(&md2_desc);
register_hash(&md4_desc);
register_hash(&md5_desc);
register_hash(&rmd128_desc);
register_hash(&rmd160_desc);
register_hash(&rmd256_desc);
register_hash(&rmd320_desc);
register_hash(&sha1_desc);
register_hash(&sha224_desc);
register_hash(&sha256_desc);
register_hash(&sha384_desc);
register_hash(&sha512_desc);
register_hash(&tiger_desc);
register_hash(&whirlpool_desc);
register_prng(&fortuna_desc);
register_prng(&rc4_desc);
register_prng(&sober128_desc);
register_prng(&sprng_desc);
register_prng(&yarrow_desc);
Tcl_CreateExitHandler(ExitHandler, NULL);
initialised = 1;
}
Tcl_MutexUnlock(&initMutex);
}