936 lines
25 KiB
C
936 lines
25 KiB
C
/*
|
||
*
|
||
* t c l - l i b . c - A library remplacement for simulating
|
||
* a Tcl interpreter in Scheme
|
||
*
|
||
* Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
||
*
|
||
*
|
||
* Permission to use, copy, modify, distribute,and license this
|
||
* software and its documentation for any purpose is hereby granted,
|
||
* provided that existing copyright notices are retained in all
|
||
* copies and that this notice is included verbatim in any
|
||
* distributions. No written agreement, license, or royalty fee is
|
||
* required for any of the authorized uses.
|
||
* This software is provided ``AS IS'' without express or implied
|
||
* warranty.
|
||
*
|
||
* Author: Erick Gallesio [eg@unice.fr]
|
||
* Creation date: 19-Feb-1993 22:15
|
||
* Last file update: 3-Sep-1999 20:59 (eg)
|
||
*
|
||
*/
|
||
|
||
|
||
#include "stk.h"
|
||
#include "module.h"
|
||
#include "gc.h"
|
||
|
||
#ifdef USE_TK
|
||
# include "tk-glue.h"
|
||
#else
|
||
# include "tclInt.h"
|
||
#endif
|
||
|
||
|
||
#ifdef USE_TK
|
||
#define BUFF_SIZE 100
|
||
/******************************************************************************
|
||
*
|
||
* Eval functions
|
||
*
|
||
******************************************************************************/
|
||
|
||
int Tcl_GlobalEval(interp, s)
|
||
Tcl_Interp *interp;
|
||
char *s;
|
||
{
|
||
char buffer[BUFF_SIZE+3], *ptr = buffer;
|
||
SCM result;
|
||
|
||
/*
|
||
* If the callback is not surrounded by parenthesis, add them. We
|
||
* don't have parenthesis when the callback is a closure. In this
|
||
* case, the callback is simply #p12345. Note that this allow Tk to
|
||
* add some parameters to the callback when needed (on bindings, or
|
||
* scrollbars for instance). To recognize such cases, we look at
|
||
* first character: if it is not an open parenthesis, we add a pair
|
||
* of () around the callback string
|
||
*
|
||
*/
|
||
if (*s == '\0') return TCL_OK;
|
||
if (*s != '(') {
|
||
/* Build the command to evaluate by adding a pair of parenthesis */
|
||
int len = strlen(s);
|
||
|
||
if (len > BUFF_SIZE)
|
||
ptr = (char *) must_malloc((size_t) len+3);
|
||
sprintf(ptr, "(%s)", s);
|
||
s = ptr;
|
||
}
|
||
result = STk_internal_eval_string(s, ERR_TCL_BACKGROUND, MOD_ENV(STk_Tk_module));
|
||
Tcl_ResetResult(interp);
|
||
|
||
if (ptr != buffer) free(ptr);
|
||
|
||
if (result != EVAL_ERROR) {
|
||
SCM dumb;
|
||
|
||
Tcl_SetResult(interp,
|
||
STk_stringify(STk_convert_for_Tcl(result, &dumb), 0),
|
||
TCL_DYNAMIC);
|
||
/*
|
||
* Store also the "true" result in STk_last_Tk_result
|
||
* Warning: This pointer inot GC protected. We have to use it very soon
|
||
* This is a kludge (used in text window)
|
||
*/
|
||
STk_last_Tk_result = result;
|
||
|
||
return (result == Sym_break) ? TCL_BREAK : TCL_OK;
|
||
}
|
||
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
int Tcl_Eval(interp, s) /* very simplist. */
|
||
Tcl_Interp *interp; /* But do we need something more clever? */
|
||
char *s;
|
||
{
|
||
return Tcl_GlobalEval(interp, s);
|
||
}
|
||
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_VarEval --
|
||
*
|
||
* Given a variable number of string arguments, concatenate them
|
||
* all together and execute the result as a Tcl command.
|
||
*
|
||
* Results:
|
||
* A standard Tcl return result. An error message or other
|
||
* result may be left in interp->result.
|
||
*
|
||
* Side effects:
|
||
* Depends on what was done by the command.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
/* VARARGS2 */ /* ARGSUSED */
|
||
int
|
||
Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1)
|
||
{
|
||
va_list argList;
|
||
Tcl_DString buf;
|
||
char *string;
|
||
Tcl_Interp *interp;
|
||
int result;
|
||
|
||
/*
|
||
* Copy the strings one after the other into a single larger
|
||
* string. Use stack-allocated space for small commands, but if
|
||
* the command gets too large than call ckalloc to create the
|
||
* space.
|
||
*/
|
||
|
||
interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
|
||
Tcl_DStringInit(&buf);
|
||
while (1) {
|
||
string = va_arg(argList, char *);
|
||
if (string == NULL) {
|
||
break;
|
||
}
|
||
Tcl_DStringAppend(&buf, string, -1);
|
||
}
|
||
va_end(argList);
|
||
|
||
result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
|
||
Tcl_DStringFree(&buf);
|
||
return result;
|
||
}
|
||
|
||
/******************************************************************************
|
||
*
|
||
* Variable accesses (GetVar, GetVar2, SetVar, SetVar2)
|
||
*
|
||
******************************************************************************/
|
||
|
||
char *Tcl_GetVar(interp, var, flags)
|
||
Tcl_Interp *interp; /* not used */
|
||
char *var;
|
||
int flags;
|
||
{
|
||
/*FIXME Debug("Usage of Tcl_GetVar for ", STk_makestring(var)); */
|
||
return STk_tcl_getvar(var, "#f");
|
||
}
|
||
|
||
char *Tcl_GetVar2(interp, name1, name2, flags)
|
||
Tcl_Interp *interp; /* not used */
|
||
char *name1, *name2;
|
||
int flags;
|
||
{
|
||
/*FIXME Debug("Usage of Tcl_GetVar2 for ", STk_makestring(name1)); */
|
||
return STk_tcl_getvar2(name1, name2, "#f");
|
||
|
||
}
|
||
|
||
char *Tcl_SetVar(interp, var, val, flags)
|
||
Tcl_Interp *interp;
|
||
char *var, *val;
|
||
int flags;
|
||
{
|
||
/*FIXME Debug("Usage of Tcl_SetVar for ", STk_makestring(var)); */
|
||
return STk_tcl_setvar(var, val, flags, "#f");
|
||
}
|
||
|
||
char *Tcl_SetVar2(interp, name1, name2, val, flags)
|
||
Tcl_Interp *interp;
|
||
char *name1, *name2, *val;
|
||
int flags;
|
||
{
|
||
/*FIXME Debug("Usage of Tcl_SetVar for ", STk_makestring(name1)); */
|
||
return STk_tcl_setvar2(name1, name2, val, flags, "#f");
|
||
}
|
||
|
||
/******************************************************************************
|
||
*
|
||
* Tcl command management
|
||
*
|
||
******************************************************************************/
|
||
|
||
int STk_internal_Tcl_DeleteCommand(interp, cmdName)
|
||
Tcl_Interp *interp;
|
||
char *cmdName;
|
||
{
|
||
struct Tk_command *W;
|
||
Interp *iPtr = (Interp *) interp;
|
||
Tcl_HashEntry *hPtr;
|
||
|
||
/* the internal DeleteCommand do all the job (except setting cmdName to
|
||
* UNBOUND, because this implies to use intern which can allocate a cell)
|
||
* Consequently, GC calls this function, whereas Tk call the true
|
||
* DeleteCommand
|
||
*/
|
||
hPtr = Tcl_FindHashEntry(&iPtr->globalNsPtr->cmdTable, cmdName);
|
||
if (hPtr == NULL) return -1;
|
||
|
||
W = (struct Tk_command *) Tcl_GetHashValue(hPtr);
|
||
if (W->deleted) return -1;
|
||
|
||
/* Execute the delete handler */
|
||
if (W->delproc != NULL) (*W->delproc)(W->deldata);
|
||
|
||
/* Note: W will be freed by the GC */
|
||
Tcl_DeleteHashEntry(hPtr);
|
||
|
||
/* Delete the command from the callbacks hash table */
|
||
STk_delete_callback(cmdName);
|
||
|
||
/* Remember that the command has been deleted */
|
||
W->deleted = 1;
|
||
|
||
return 0;
|
||
}
|
||
|
||
|
||
int Tcl_DeleteCommand(interp, cmdName)
|
||
Tcl_Interp *interp;
|
||
char *cmdName;
|
||
{
|
||
int result;
|
||
|
||
if ((result = STk_internal_Tcl_DeleteCommand(interp, cmdName)))
|
||
return result;
|
||
|
||
/* Undefine "cmdName" by doing a (set! cmdname #<unbound>) */
|
||
STk_define_variable(cmdName, UNBOUND, STk_Tk_module);
|
||
|
||
return 0;
|
||
}
|
||
|
||
|
||
/*
|
||
* Tcl_DeleteCommandFromToken --
|
||
*
|
||
* Removes the given command from the given interpreter. This procedure
|
||
* resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead
|
||
* of a command name for efficiency.
|
||
*/
|
||
|
||
int
|
||
Tcl_DeleteCommandFromToken(interp, cmd)
|
||
Tcl_Interp *interp; /* Token for command interpreter returned by
|
||
* a previous call to Tcl_CreateInterp. */
|
||
Tcl_Command cmd; /* Token for command to delete. */
|
||
{
|
||
/* In STk this function is less efficient than the Tcl one since it
|
||
* searches the name of the given command and call Tcl_DeleteCommand
|
||
* However, the time penalty should be lower than in Tcl here.
|
||
*/
|
||
return Tcl_DeleteCommand(interp, Tcl_GetCommandName(interp, cmd));
|
||
}
|
||
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_CreateCommand --
|
||
*
|
||
* Define a new command in a command table.
|
||
*
|
||
* Results:
|
||
* The return value is a token for the command, which can
|
||
* be used in future calls to Tcl_NameOfCommand.
|
||
*
|
||
* Side effects:
|
||
* If a command named cmdName already exists for interp, it is
|
||
* deleted.
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
Tcl_Command
|
||
Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
|
||
Tcl_Interp *interp; /* Token for command interpreter (returned
|
||
* by a previous call to Tcl_CreateInterp). */
|
||
char *cmdName; /* Name of command. */
|
||
Tcl_CmdProc *proc; /* Command procedure to associate with
|
||
* cmdName. */
|
||
ClientData clientData; /* Arbitrary one-word value to pass to proc. */
|
||
Tcl_CmdDeleteProc *deleteProc;
|
||
/* If not NULL, gives a procedure to call when
|
||
* this command is deleted. */
|
||
{
|
||
struct Tk_command * W;
|
||
Interp *iPtr = (Interp *) interp;
|
||
Tcl_HashEntry *hPtr;
|
||
int new;
|
||
SCM z;
|
||
|
||
/*
|
||
* There are two things to do here.
|
||
* - We must create a new variable and associate the newly
|
||
* created Tk object to it. This is the Scheme part.
|
||
* - We must store the cmd in a hashtable contained in the interp data
|
||
* structure. This is necessary to delete all the command associated
|
||
* to the interpreter. This is important at least for the "send"
|
||
* command which un-register the interpreter from the X server.
|
||
*
|
||
*/
|
||
|
||
/* Initialize the Tk_command structure */
|
||
W = (struct Tk_command *)must_malloc(sizeof(struct Tk_command)+strlen(cmdName));
|
||
W->ptr = clientData;
|
||
W->fct = proc;
|
||
W->delproc = deleteProc;
|
||
W->deldata = clientData;
|
||
W->deleted = 0;
|
||
W->objproc = 0;
|
||
strcpy(W->Id, cmdName);
|
||
|
||
/* Register the command in the Tcl command hash table */
|
||
if (Tcl_FindHashEntry(&iPtr->globalNsPtr->cmdTable, cmdName)) {
|
||
/* Command already exists: delete the old one */
|
||
Tcl_DeleteCommand(interp, cmdName); /* not efficient but safer */
|
||
}
|
||
hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, cmdName, &new);
|
||
Tcl_SetHashValue(hPtr, W);
|
||
|
||
/* Define a Tk-command cell for this new command */
|
||
NEWCELL(z, tc_tkcommand);
|
||
z->storage_as.tk.data = W;
|
||
z->storage_as.tk.l_data = Ntruth;
|
||
|
||
/* Define a variable whose name is the command name */
|
||
STk_define_variable(cmdName, z, STk_Tk_module);
|
||
|
||
return (Tcl_Command) W;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_GetCommandName --
|
||
*
|
||
* Given a token returned by Tcl_CreateCommand, this procedure
|
||
* returns the current name of the command (which may have changed
|
||
* due to renaming).
|
||
*
|
||
* Results:
|
||
* The return value is the name of the given command.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
char *
|
||
Tcl_GetCommandName(interp, command)
|
||
Tcl_Interp *interp; /* Interpreter containing the command. */
|
||
Tcl_Command command; /* Token for the command, returned by a
|
||
* previous call to Tcl_CreateCommand.
|
||
* The command must not have been deleted. */
|
||
{
|
||
return ((struct Tk_command *) command)->Id;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_GetCommandInfo --
|
||
*
|
||
* Returns various information about a Tcl command.
|
||
*
|
||
* Results:
|
||
* If cmdName exists in interp, then *infoPtr is modified to
|
||
* hold information about cmdName and 1 is returned. If the
|
||
* command doesn't exist then 0 is returned and *infoPtr isn't
|
||
* modified.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_GetCommandInfo(interp, cmdName, infoPtr)
|
||
Tcl_Interp *interp; /* Interpreter in which to look
|
||
* for command. */
|
||
char *cmdName; /* Name of desired command. */
|
||
Tcl_CmdInfo *infoPtr; /* Where to store information about
|
||
* command. */
|
||
{
|
||
SCM v;
|
||
struct Tk_command *p;
|
||
|
||
v = STk_lookup_variable(cmdName, STk_Tk_module);
|
||
if (NTKCOMMP(v)) return 0;
|
||
|
||
p = v->storage_as.tk.data;
|
||
|
||
infoPtr->proc = p->fct;
|
||
infoPtr->clientData = p->ptr;
|
||
infoPtr->deleteProc = p->delproc;;
|
||
infoPtr->deleteData = NULL;
|
||
return 1;
|
||
}
|
||
|
||
|
||
/******************************************************************************
|
||
*
|
||
* Tcl interpreter management
|
||
*
|
||
******************************************************************************/
|
||
|
||
Tcl_Interp *Tcl_CreateInterp()
|
||
{
|
||
register Interp *iPtr = (Interp *) ckalloc(sizeof(Interp));
|
||
int i;
|
||
|
||
iPtr->result = iPtr->resultSpace;
|
||
iPtr->freeProc = 0;
|
||
iPtr->errorLine = 0;
|
||
iPtr->resultSpace[0] = 0;
|
||
|
||
for (i = 0; i < NUM_REGEXPS; i++) {
|
||
iPtr->patterns[i] = NULL;
|
||
iPtr->patLengths[i] = -1;
|
||
iPtr->regexps[i] = NULL;
|
||
}
|
||
|
||
iPtr->appendResult = NULL;
|
||
iPtr->appendAvl = 0;
|
||
iPtr->appendUsed = 0;
|
||
iPtr->flags = 0;
|
||
|
||
/* strcpy(iPtr->pdFormat, "%g"); No more needed for 8.0 */
|
||
|
||
iPtr->assocData = (Tcl_HashTable *) NULL;
|
||
|
||
/* See Tcl_CreateCommand for this table utility */
|
||
iPtr->globalNsPtr = (Namespace*) STk_must_malloc(sizeof(Namespace));
|
||
Tcl_InitHashTable(&iPtr->globalNsPtr->cmdTable, TCL_STRING_KEYS);
|
||
|
||
/* Protect the Tcl_Obj result */
|
||
Tcl_ResetObjResult(iPtr);
|
||
STk_gc_protect((SCM*) &(iPtr->objResultPtr));
|
||
|
||
return (Tcl_Interp *) iPtr;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_SetAssocData --
|
||
*
|
||
* Creates a named association between user-specified data, a delete
|
||
* function and this interpreter. If the association already exists
|
||
* the data is overwritten with the new data. The delete function will
|
||
* be invoked when the interpreter is deleted.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* Sets the associated data, creates the association if needed.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
Tcl_SetAssocData(interp, name, proc, clientData)
|
||
Tcl_Interp *interp; /* Interpreter to associate with. */
|
||
char *name; /* Name for association. */
|
||
Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is
|
||
* about to be deleted. */
|
||
ClientData clientData; /* One-word value to pass to proc. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
AssocData *dPtr;
|
||
Tcl_HashEntry *hPtr;
|
||
int new;
|
||
|
||
if (iPtr->assocData == (Tcl_HashTable *) NULL) {
|
||
if (iPtr->flags & DELETED) {
|
||
/*
|
||
* Don't create new entries after interpreter deletion
|
||
* has started; it isn't even safe to muck with the
|
||
* interpreter right now
|
||
*/
|
||
|
||
return;
|
||
}
|
||
iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
|
||
Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
|
||
}
|
||
hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new);
|
||
if (new == 0) {
|
||
dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
|
||
} else {
|
||
dPtr = (AssocData *) ckalloc(sizeof(AssocData));
|
||
}
|
||
dPtr->proc = proc;
|
||
dPtr->clientData = clientData;
|
||
|
||
Tcl_SetHashValue(hPtr, dPtr);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_DeleteAssocData --
|
||
*
|
||
* Deletes a named association of user-specified data with
|
||
* the specified interpreter.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* Deletes the association.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
Tcl_DeleteAssocData(interp, name)
|
||
Tcl_Interp *interp; /* Interpreter to associate with. */
|
||
char *name; /* Name of association. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
AssocData *dPtr;
|
||
Tcl_HashEntry *hPtr;
|
||
|
||
if (iPtr->assocData == (Tcl_HashTable *) NULL) {
|
||
return;
|
||
}
|
||
hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
|
||
if (hPtr == (Tcl_HashEntry *) NULL) {
|
||
return;
|
||
}
|
||
dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
|
||
ckfree((char *) dPtr);
|
||
Tcl_DeleteHashEntry(hPtr);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_GetAssocData --
|
||
*
|
||
* Returns the client data associated with this name in the
|
||
* specified interpreter.
|
||
*
|
||
* Results:
|
||
* The client data in the AssocData record denoted by the named
|
||
* association, or NULL.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
ClientData
|
||
Tcl_GetAssocData(interp, name, procPtr)
|
||
Tcl_Interp *interp; /* Interpreter associated with. */
|
||
char *name; /* Name of association. */
|
||
Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address
|
||
* of current deletion callback. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
AssocData *dPtr;
|
||
Tcl_HashEntry *hPtr;
|
||
|
||
if (iPtr->assocData == (Tcl_HashTable *) NULL) {
|
||
return (ClientData) NULL;
|
||
}
|
||
hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
|
||
if (hPtr == (Tcl_HashEntry *) NULL) {
|
||
return (ClientData) NULL;
|
||
}
|
||
dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
|
||
if (procPtr != (Tcl_InterpDeleteProc **) NULL) {
|
||
*procPtr = dPtr->proc;
|
||
}
|
||
return dPtr->clientData;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_InterpDeleted --
|
||
*
|
||
* Returns nonzero if the interpreter has been deleted with a call
|
||
* to Tcl_DeleteInterp.
|
||
*
|
||
* Results:
|
||
* Nonzero if the interpreter is deleted, zero otherwise.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_InterpDeleted(interp)
|
||
Tcl_Interp *interp;
|
||
{
|
||
return (((Interp *) interp)->flags & DELETED) ? 1 : 0;
|
||
}
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_DeleteInterp --
|
||
*
|
||
* Delete an interpreter and free up all of the resources associated
|
||
* with it.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* The interpreter is destroyed. The caller should never again
|
||
* use the interp token.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
void Tcl_DeleteInterp(interp)
|
||
Tcl_Interp *interp;
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
Tcl_HashEntry *hPtr;
|
||
Tcl_HashSearch search;
|
||
struct Tk_command *W;
|
||
|
||
if (!iPtr || (iPtr->flags & DELETED)) return;
|
||
|
||
/* Mark the interpreter as deleted. No further evals will be allowed. */
|
||
iPtr->flags |= DELETED;
|
||
|
||
/* Delete result space */
|
||
if (iPtr->appendResult != NULL) {
|
||
ckfree(iPtr->appendResult);
|
||
}
|
||
|
||
/* delete hash table of Tk commands (see Tcl_CreateCommand) */
|
||
for (hPtr = Tcl_FirstHashEntry(&iPtr->globalNsPtr->cmdTable, &search);
|
||
hPtr != NULL;
|
||
hPtr = Tcl_NextHashEntry(&search)) {
|
||
W = (struct Tk_command *) Tcl_GetHashValue(hPtr);
|
||
Tcl_DeleteCommand(interp, W->Id);
|
||
}
|
||
Tcl_DeleteHashTable(&iPtr->globalNsPtr->cmdTable);
|
||
|
||
/* Unprotect the Tcl_Obj result */
|
||
STk_gc_unprotect((SCM*) &(iPtr->objResultPtr));
|
||
|
||
ckfree((char *) iPtr);
|
||
}
|
||
|
||
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_GetOpenFile --
|
||
*
|
||
* Given a name of a channel registered in the given interpreter,
|
||
* returns a FILE * for it.
|
||
*
|
||
* Results:
|
||
* A standard Tcl result. If the channel is registered in the given
|
||
* interpreter and it is managed by the "file" channel driver, and
|
||
* it is open for the requested mode, then the output parameter
|
||
* filePtr is set to a FILE * for the underlying file. On error, the
|
||
* filePtr is not set, TCL_ERROR is returned and an error message is
|
||
* left in interp->result.
|
||
*
|
||
* Side effects:
|
||
* May invoke fdopen to create the FILE * for the requested file.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_GetOpenFile(interp, string, forWriting, checkUsage, filePtr)
|
||
Tcl_Interp *interp; /* Interpreter in which to find file. */
|
||
char *string; /* String that identifies file. */
|
||
int forWriting; /* 1 means the file is going to be used
|
||
* for writing, 0 means for reading. */
|
||
int checkUsage; /* 1 means verify that the file was opened
|
||
* in a mode that allows the access specified
|
||
* by "forWriting". Ignored, we always
|
||
* check that the channel is open for the
|
||
* requested mode. */
|
||
ClientData *filePtr; /* Store pointer to FILE structure here. */
|
||
{
|
||
SCM port;
|
||
|
||
if ((string[0] == '#') && (string[1] == 'f') && (string[2] == 'i')
|
||
&& (string[3] == 'l') && string[4] == 'e') {
|
||
char *end;
|
||
|
||
port = (SCM) strtoul(string+5, &end, 16);
|
||
if ((end != string+5) && (*end == 0)) {
|
||
/* Verify the given address is a port */
|
||
if (STk_valid_address(port) && (IPORTP(port) || OPORTP(port))) {
|
||
/* Verify the port usage */
|
||
if (checkUsage && (PORT_FLAGS(port) & PORT_CLOSED)) {
|
||
Tcl_AppendResult(interp, "\"", string,
|
||
"\" is closed", (char *) NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
if (forWriting) {
|
||
if (checkUsage && !OPORTP(port)) {
|
||
Tcl_AppendResult(interp, "\"", string,
|
||
"\" wasn't opened for writing", (char *) NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
else {
|
||
if (!IPORTP(port)) {
|
||
Tcl_AppendResult(interp, "\"", string,
|
||
"\" wasn't opened for reading", (char *) NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
|
||
/* File is correct; return it in filePtr */
|
||
*filePtr = (ClientData) PORT_FILE(port);
|
||
return TCL_OK;
|
||
}
|
||
}
|
||
}
|
||
Tcl_AppendResult(interp, "Bad file specification \"", string,
|
||
"\"", (char *) NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
#endif
|
||
|
||
/******************************************************************************
|
||
*
|
||
* Tcl channels simulation.
|
||
*
|
||
* Current version is very minimal. It should probably be extended to be
|
||
* more Tcl compatible, since Tcl model is very neat.
|
||
*
|
||
******************************************************************************/
|
||
|
||
Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, char *fileName,
|
||
char *modeString, int permissions)
|
||
{
|
||
FILE *f = fopen(fileName, modeString);
|
||
|
||
if (f == NULL) {
|
||
if (interp != (Tcl_Interp *) NULL) {
|
||
Tcl_AppendResult(interp, "couldn't open \"", fileName, "\": ",
|
||
Tcl_PosixError(interp), (char *) NULL);
|
||
}
|
||
}
|
||
return (Tcl_Channel) f;
|
||
}
|
||
|
||
int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan)
|
||
{
|
||
return fclose((FILE *) chan);
|
||
}
|
||
|
||
int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead)
|
||
{
|
||
clearerr((FILE*) chan);
|
||
return fread(bufPtr, 1, (size_t) toRead, (FILE*) chan);
|
||
}
|
||
|
||
int Tcl_Write(Tcl_Channel chan, char *s, int slen)
|
||
{
|
||
int len = (slen < 0) ? strlen(s) : slen;
|
||
|
||
return fwrite(s, 1, (size_t) len, (FILE*) chan);
|
||
}
|
||
|
||
|
||
int Tcl_Seek(Tcl_Channel chan, int offset, int mode)
|
||
{
|
||
int res;
|
||
|
||
if ((res=fseek((FILE*) chan, (long) offset, mode)) != -1)
|
||
return (int) ftell((FILE*) chan);
|
||
|
||
return res;
|
||
}
|
||
|
||
int Tcl_Flush(Tcl_Channel chan)
|
||
{
|
||
return fflush((FILE *) chan);
|
||
}
|
||
|
||
|
||
int Tcl_Eof(Tcl_Channel chan) /* Does this channel have EOF? */
|
||
{
|
||
return feof((FILE *) chan);
|
||
}
|
||
|
||
int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, char *optionName,
|
||
char *newValue)
|
||
{
|
||
/* Do nothing */
|
||
return TCL_OK;
|
||
}
|
||
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_IsSafe --
|
||
*
|
||
* Determines whether an interpreter is safe
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_IsSafe(interp)
|
||
Tcl_Interp *interp; /* Is this interpreter "safe" ? */
|
||
{
|
||
return STk_is_safe; /* STk is always unsafe for now, but this
|
||
could change ... */
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_HideCommand --
|
||
*
|
||
* Makes a command hidden so that it cannot be invoked from within
|
||
* an interpreter, only from within an ancestor.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_HideCommand(interp, cmdName, hiddenCmdName)
|
||
Tcl_Interp *interp; /* Interpreter in which to hide command. */
|
||
char *cmdName; /* Name of hidden command. */
|
||
char *hiddenCmdName; /* Name of to-be-hidden command. */
|
||
{
|
||
/* Easy job */
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_WrongNumArgs --
|
||
*
|
||
* This procedure generates a "wrong # args" error message in an
|
||
* interpreter. It is used as a utility function by many command
|
||
* procedures.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* An error message is generated in interp's result object to
|
||
* indicate that a command was invoked with the wrong number of
|
||
* arguments. The message has the form
|
||
* wrong # args: should be "foo bar additional stuff"
|
||
* where "foo" and "bar" are the initial objects in objv (objc
|
||
* determines how many of these are printed) and "additional stuff"
|
||
* is the contents of the message argument.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
Tcl_WrongNumArgs(interp, objc, objv, message)
|
||
Tcl_Interp *interp; /* Current interpreter. */
|
||
int objc; /* Number of arguments to print
|
||
* from objv. */
|
||
Tcl_Obj *CONST objv[]; /* Initial argument objects, which
|
||
* should be included in the error
|
||
* message. */
|
||
char *message; /* Error message to print after the
|
||
* leading objects in objv. */
|
||
{
|
||
Tcl_Obj *objPtr;
|
||
int i;
|
||
#ifdef STk_CODE
|
||
int stk_hack = (objc == 2);
|
||
#endif
|
||
|
||
objPtr = Tcl_GetObjResult(interp);
|
||
#ifdef STk_CODE
|
||
Tcl_AppendToObj(objPtr, "wrong # args: should be (", -1);
|
||
for (i = 0; i < objc; i++) {
|
||
|
||
if (stk_hack && i == 1) {
|
||
/* VERY VERY HACKY: place a quote in front of the second element
|
||
* of the message. This is a special case for messages such as
|
||
* wrong # args: should be (.but 'configure ....)
|
||
* But this code is so frequent.
|
||
*/
|
||
Tcl_AppendStringsToObj(objPtr, "'",
|
||
Tcl_GetStringFromObj(objv[i], (int *) NULL), " ",
|
||
(char *) NULL);
|
||
}
|
||
else {
|
||
Tcl_AppendStringsToObj(objPtr,
|
||
Tcl_GetStringFromObj(objv[i], (int *) NULL), " ",
|
||
(char *) NULL);
|
||
}
|
||
}
|
||
Tcl_AppendStringsToObj(objPtr, message, ")", (char *) NULL);
|
||
#else
|
||
Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
|
||
for (i = 0; i < objc; i++) {
|
||
Tcl_AppendStringsToObj(objPtr,
|
||
Tcl_GetStringFromObj(objv[i], (int *) NULL), " ",
|
||
(char *) NULL);
|
||
}
|
||
Tcl_AppendStringsToObj(objPtr, message, "\"", (char *) NULL);
|
||
#endif
|
||
}
|