504 lines
12 KiB
C
504 lines
12 KiB
C
|
/*
|
|||
|
*
|
|||
|
* t c l - u t i l . c -- Some Tcl utilities (this correpond to part
|
|||
|
* of code of the Tcl lib modified to take into
|
|||
|
* account some Scheme specificities)
|
|||
|
*
|
|||
|
* Copyright <EFBFBD> 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|||
|
*
|
|||
|
*
|
|||
|
* Permission to use, copy, and/or distribute this software and its
|
|||
|
* documentation for any purpose and without fee is hereby granted, provided
|
|||
|
* that both the above copyright notice and this permission notice appear in
|
|||
|
* all copies and derived works. Fees for distribution or use of this
|
|||
|
* software or derived works may only be charged with express written
|
|||
|
* permission of the copyright holder.
|
|||
|
* This software is provided ``as is'' without express or implied warranty.
|
|||
|
*
|
|||
|
* This software is a derivative work of other copyrighted softwares; the
|
|||
|
* copyright notices of these softwares are placed in the file COPYRIGHTS
|
|||
|
*
|
|||
|
*
|
|||
|
* Author: Erick Gallesio [eg@unice.fr]
|
|||
|
* Creation date: 26-Feb-1993 10:10
|
|||
|
* Last file update: 14-Jul-1996 21:58
|
|||
|
*
|
|||
|
*
|
|||
|
* This code is derivated from several Tcl files which have the following
|
|||
|
* copyright notice
|
|||
|
*
|
|||
|
* Copyright (c) 1990-1993 The Regents of the University of California.
|
|||
|
* Copyright (c) 1994 Sun Microsystems, Inc.
|
|||
|
*
|
|||
|
* See the file "license.terms" for information on usage and redistribution
|
|||
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
|||
|
*/
|
|||
|
|
|||
|
#include "stk.h"
|
|||
|
#ifndef WIN32
|
|||
|
# include <tclInt.h>
|
|||
|
# include <tclPort.h>
|
|||
|
#endif
|
|||
|
|
|||
|
|
|||
|
/*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* Tcl_PosixError --
|
|||
|
*
|
|||
|
* This procedure is typically called after UNIX kernel calls
|
|||
|
* return errors. It stores machine-readable information about
|
|||
|
* the error in $errorCode returns an information string for
|
|||
|
* the caller's use.
|
|||
|
*
|
|||
|
* Results:
|
|||
|
* The return value is a human-readable string describing the
|
|||
|
* error, as returned by strerror.
|
|||
|
*
|
|||
|
* Side effects:
|
|||
|
* The global variable $errorCode is reset.
|
|||
|
*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
char *
|
|||
|
Tcl_PosixError(interp)
|
|||
|
Tcl_Interp *interp; /* Interpreter whose $errorCode variable
|
|||
|
* is to be changed. */
|
|||
|
{
|
|||
|
#ifdef STk_CODE
|
|||
|
return (char *) strerror(errno);
|
|||
|
#else
|
|||
|
char *id, *msg;
|
|||
|
|
|||
|
id = Tcl_ErrnoId();
|
|||
|
msg = strerror(errno);
|
|||
|
Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL);
|
|||
|
return msg;
|
|||
|
#endif
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* Tcl_Backslash --
|
|||
|
*
|
|||
|
* Figure out how to handle a backslash sequence.
|
|||
|
*
|
|||
|
* Results:
|
|||
|
* The return value is the character that should be substituted
|
|||
|
* in place of the backslash sequence that starts at src. If
|
|||
|
* readPtr isn't NULL then it is filled in with a count of the
|
|||
|
* number of characters in the backslash sequence.
|
|||
|
*
|
|||
|
* Side effects:
|
|||
|
* None.
|
|||
|
*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
char
|
|||
|
Tcl_Backslash(src, readPtr)
|
|||
|
char *src; /* Points to the backslash character of
|
|||
|
* a backslash sequence. */
|
|||
|
int *readPtr; /* Fill in with number of characters read
|
|||
|
* from src, unless NULL. */
|
|||
|
{
|
|||
|
register char *p = src+1;
|
|||
|
char result;
|
|||
|
int count;
|
|||
|
|
|||
|
count = 2;
|
|||
|
|
|||
|
switch (*p) {
|
|||
|
case 'a':
|
|||
|
result = 0x7; /* Don't say '\a' here, since some compilers */
|
|||
|
break; /* don't support it. */
|
|||
|
case 'b':
|
|||
|
result = '\b';
|
|||
|
break;
|
|||
|
case 'f':
|
|||
|
result = '\f';
|
|||
|
break;
|
|||
|
case 'n':
|
|||
|
result = '\n';
|
|||
|
break;
|
|||
|
case 'r':
|
|||
|
result = '\r';
|
|||
|
break;
|
|||
|
case 't':
|
|||
|
result = '\t';
|
|||
|
break;
|
|||
|
case 'v':
|
|||
|
result = '\v';
|
|||
|
break;
|
|||
|
case 'x':
|
|||
|
if (isxdigit(UCHAR(p[1]))) {
|
|||
|
char *end;
|
|||
|
|
|||
|
result = strtoul(p+1, &end, 16);
|
|||
|
count = end - src;
|
|||
|
} else {
|
|||
|
count = 2;
|
|||
|
result = 'x';
|
|||
|
}
|
|||
|
break;
|
|||
|
case '\n':
|
|||
|
do {
|
|||
|
p++;
|
|||
|
} while (isspace(UCHAR(*p)));
|
|||
|
result = ' ';
|
|||
|
count = p - src;
|
|||
|
break;
|
|||
|
case 0:
|
|||
|
result = '\\';
|
|||
|
count = 1;
|
|||
|
break;
|
|||
|
default:
|
|||
|
if (isdigit(UCHAR(*p))) {
|
|||
|
result = *p - '0';
|
|||
|
p++;
|
|||
|
if (!isdigit(UCHAR(*p))) {
|
|||
|
break;
|
|||
|
}
|
|||
|
count = 3;
|
|||
|
result = (result << 3) + (*p - '0');
|
|||
|
p++;
|
|||
|
if (!isdigit(UCHAR(*p))) {
|
|||
|
break;
|
|||
|
}
|
|||
|
count = 4;
|
|||
|
result = (result << 3) + (*p - '0');
|
|||
|
break;
|
|||
|
}
|
|||
|
result = *p;
|
|||
|
count = 2;
|
|||
|
break;
|
|||
|
}
|
|||
|
|
|||
|
if (readPtr != NULL) {
|
|||
|
*readPtr = count;
|
|||
|
}
|
|||
|
return result;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* Tcl_TildeSubst --
|
|||
|
*
|
|||
|
* Given a name starting with a tilde, produce a name where
|
|||
|
* the tilde and following characters have been replaced by
|
|||
|
* the home directory location for the named user.
|
|||
|
*
|
|||
|
* Results:
|
|||
|
* The result is a pointer to a static string containing
|
|||
|
* the new name. If there was an error in processing the
|
|||
|
* tilde, then an error message is left in interp->result
|
|||
|
* and the return value is NULL. The result may be stored
|
|||
|
* in bufferPtr; the caller must call Tcl_DStringFree(bufferPtr)
|
|||
|
* to free the name.
|
|||
|
*
|
|||
|
* Side effects:
|
|||
|
* Information may be left in bufferPtr.
|
|||
|
*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
char *
|
|||
|
Tcl_TildeSubst(interp, name, bufferPtr)
|
|||
|
Tcl_Interp *interp; /* Interpreter in which to store error
|
|||
|
* message (if necessary). */
|
|||
|
char *name; /* File name, which may begin with "~/"
|
|||
|
* (to indicate current user's home directory)
|
|||
|
* or "~<user>/" (to indicate any user's
|
|||
|
* home directory). */
|
|||
|
Tcl_DString *bufferPtr; /* May be used to hold result. Must not hold
|
|||
|
* anything at the time of the call, and need
|
|||
|
* not even be initialized. */
|
|||
|
{
|
|||
|
char *dir;
|
|||
|
register char *p;
|
|||
|
|
|||
|
Tcl_DStringInit(bufferPtr);
|
|||
|
if (name[0] != '~') {
|
|||
|
return name;
|
|||
|
}
|
|||
|
|
|||
|
if ((name[1] == '/') || (name[1] == '\0')) {
|
|||
|
dir = getenv("HOME");
|
|||
|
if (dir == NULL) {
|
|||
|
Tcl_ResetResult(interp);
|
|||
|
Tcl_AppendResult(interp, "couldn't find HOME environment ",
|
|||
|
"variable to expand \"", name, "\"", (char *) NULL);
|
|||
|
return NULL;
|
|||
|
}
|
|||
|
Tcl_DStringAppend(bufferPtr, dir, -1);
|
|||
|
Tcl_DStringAppend(bufferPtr, name+1, -1);
|
|||
|
} else {
|
|||
|
struct passwd *pwPtr;
|
|||
|
|
|||
|
for (p = &name[1]; (*p != 0) && (*p != '/'); p++) {
|
|||
|
/* Null body; just find end of name. */
|
|||
|
}
|
|||
|
Tcl_DStringAppend(bufferPtr, name+1, p - (name+1));
|
|||
|
#ifdef WIN32
|
|||
|
Tcl_ResetResult(interp);
|
|||
|
Tcl_AppendResult(interp, "user \"", bufferPtr->string,
|
|||
|
"\" doesn't exist", (char *) NULL);
|
|||
|
return NULL;
|
|||
|
}
|
|||
|
#else
|
|||
|
pwPtr = getpwnam(bufferPtr->string);
|
|||
|
if (pwPtr == NULL) {
|
|||
|
endpwent();
|
|||
|
Tcl_ResetResult(interp);
|
|||
|
Tcl_AppendResult(interp, "user \"", bufferPtr->string,
|
|||
|
"\" doesn't exist", (char *) NULL);
|
|||
|
return NULL;
|
|||
|
}
|
|||
|
Tcl_DStringFree(bufferPtr);
|
|||
|
Tcl_DStringAppend(bufferPtr, pwPtr->pw_dir, -1);
|
|||
|
Tcl_DStringAppend(bufferPtr, p, -1);
|
|||
|
endpwent();
|
|||
|
}
|
|||
|
return bufferPtr->string;
|
|||
|
#endif
|
|||
|
}
|
|||
|
|
|||
|
|
|||
|
int Tcl_ExprDouble(interp, string, ptr)
|
|||
|
Tcl_Interp *interp; /* Context in which to evaluate the
|
|||
|
* expression. */
|
|||
|
char *string; /* Expression to evaluate. */
|
|||
|
double *ptr; /* Where to store result. */
|
|||
|
{
|
|||
|
SCM value = STk_eval_C_string(string, NIL);
|
|||
|
|
|||
|
if (value) {
|
|||
|
if (NUMBERP(value)) {
|
|||
|
*ptr = FLONM(STk_exact2inexact(value));
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
}
|
|||
|
interp->result = "expression didn't have numeric value";
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
|
|||
|
|
|||
|
int Tcl_ExprLong(interp, string, ptr)
|
|||
|
Tcl_Interp *interp; /* Context in which to evaluate the
|
|||
|
* expression. */
|
|||
|
char *string; /* Expression to evaluate. */
|
|||
|
long *ptr; /* Where to store result. */
|
|||
|
{
|
|||
|
SCM value = STk_eval_C_string(string, NIL);
|
|||
|
|
|||
|
if (value) {
|
|||
|
if (EXACTP(value)) {
|
|||
|
*ptr = (long) FLONM(STk_exact2inexact(value));
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
}
|
|||
|
interp->result = "expression didn't have numeric value";
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
|
|||
|
|
|||
|
void Tcl_AddErrorInfo(interp, message)
|
|||
|
Tcl_Interp *interp;
|
|||
|
char *message;
|
|||
|
{
|
|||
|
SCM new, old, error_info;
|
|||
|
|
|||
|
error_info = Intern("*error-info*");
|
|||
|
new = STk_makestring(message);
|
|||
|
old = VCELL(error_info);
|
|||
|
|
|||
|
if (!STRINGP(old)) old = STk_makestring("");
|
|||
|
|
|||
|
/* Append message to current value of *error-info* */
|
|||
|
VCELL(error_info) = STk_string_append(LIST2(old, new), 2);
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* Tcl_AllowExceptions --
|
|||
|
*
|
|||
|
* Sets a flag in an interpreter so that exceptions can occur
|
|||
|
* in the next call to Tcl_Eval without them being turned into
|
|||
|
* errors.
|
|||
|
*
|
|||
|
* Results:
|
|||
|
* None.
|
|||
|
*
|
|||
|
* Side effects:
|
|||
|
* The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's
|
|||
|
* evalFlags structure. See the reference documentation for
|
|||
|
* more details.
|
|||
|
*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
void
|
|||
|
Tcl_AllowExceptions(interp)
|
|||
|
Tcl_Interp *interp; /* Interpreter in which to set flag. */
|
|||
|
{
|
|||
|
Interp *iPtr = (Interp *) interp;
|
|||
|
|
|||
|
iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS;
|
|||
|
}
|
|||
|
|
|||
|
#ifdef USE_TK
|
|||
|
|
|||
|
/*
|
|||
|
*=============================================================================
|
|||
|
*
|
|||
|
* Misc
|
|||
|
*
|
|||
|
*=============================================================================
|
|||
|
*/
|
|||
|
|
|||
|
/*
|
|||
|
* The FileHashKey structure is used to associate the OS file handle and type
|
|||
|
* with the corresponding notifier data in a FileHandle.
|
|||
|
*/
|
|||
|
|
|||
|
typedef struct FileHashKey {
|
|||
|
int type; /* File handle type. */
|
|||
|
ClientData osHandle; /* Platform specific OS file handle. */
|
|||
|
} FileHashKey;
|
|||
|
|
|||
|
typedef struct FileHandle {
|
|||
|
FileHashKey key; /* Hash key for a given file. */
|
|||
|
ClientData data; /* Platform specific notifier data. */
|
|||
|
Tcl_FileFreeProc *proc; /* Callback to invoke when file is freed. */
|
|||
|
} FileHandle;
|
|||
|
|
|||
|
/*
|
|||
|
* Static variables used in this file:
|
|||
|
*/
|
|||
|
|
|||
|
static Tcl_HashTable fileTable; /* Hash table containing file handles. */
|
|||
|
static int initialized = 0; /* 1 if this module has been initialized. */
|
|||
|
|
|||
|
/*
|
|||
|
* Static procedures used in this file:
|
|||
|
*/
|
|||
|
|
|||
|
static void FileExitProc _ANSI_ARGS_((ClientData clientData));
|
|||
|
|
|||
|
/*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* Tcl_GetFile --
|
|||
|
*
|
|||
|
* This function retrieves the file handle associated with a
|
|||
|
* platform specific file handle of the given type. It creates
|
|||
|
* a new file handle if needed.
|
|||
|
*
|
|||
|
* Results:
|
|||
|
* Returns the file handle associated with the file descriptor.
|
|||
|
*
|
|||
|
* Side effects:
|
|||
|
* Initializes the file handle table if necessary.
|
|||
|
*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
Tcl_File
|
|||
|
Tcl_GetFile(osHandle, type)
|
|||
|
ClientData osHandle; /* Platform specific file handle. */
|
|||
|
int type; /* Type of file handle. */
|
|||
|
{
|
|||
|
FileHashKey key;
|
|||
|
Tcl_HashEntry *entryPtr;
|
|||
|
int new;
|
|||
|
|
|||
|
if (!initialized) {
|
|||
|
Tcl_InitHashTable(&fileTable, sizeof(FileHashKey)/sizeof(int));
|
|||
|
Tcl_CreateExitHandler(FileExitProc, 0);
|
|||
|
initialized = 1;
|
|||
|
}
|
|||
|
key.osHandle = osHandle;
|
|||
|
key.type = type;
|
|||
|
entryPtr = Tcl_CreateHashEntry(&fileTable, (char *) &key, &new);
|
|||
|
if (new) {
|
|||
|
FileHandle *newHandlePtr;
|
|||
|
|
|||
|
newHandlePtr = (FileHandle *) ckalloc(sizeof(FileHandle));
|
|||
|
newHandlePtr->key = key;
|
|||
|
newHandlePtr->data = NULL;
|
|||
|
newHandlePtr->proc = NULL;
|
|||
|
Tcl_SetHashValue(entryPtr, newHandlePtr);
|
|||
|
}
|
|||
|
|
|||
|
return (Tcl_File) Tcl_GetHashValue(entryPtr);
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* Tcl_GetFileInfo --
|
|||
|
*
|
|||
|
* This function retrieves the platform specific file data and
|
|||
|
* type from the file handle.
|
|||
|
*
|
|||
|
* Results:
|
|||
|
* If typePtr is not NULL, sets *typePtr to the type of the file.
|
|||
|
* Returns the platform specific file data.
|
|||
|
*
|
|||
|
* Side effects:
|
|||
|
* None.
|
|||
|
*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
ClientData
|
|||
|
Tcl_GetFileInfo(handle, typePtr)
|
|||
|
Tcl_File handle;
|
|||
|
int *typePtr;
|
|||
|
{
|
|||
|
FileHandle *handlePtr = (FileHandle *) handle;
|
|||
|
|
|||
|
if (typePtr) {
|
|||
|
*typePtr = handlePtr->key.type;
|
|||
|
}
|
|||
|
return handlePtr->key.osHandle;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* FileExitProc --
|
|||
|
*
|
|||
|
* This function an exit handler that frees any memory allocated
|
|||
|
* for the file handle table.
|
|||
|
*
|
|||
|
* Results:
|
|||
|
* None.
|
|||
|
*
|
|||
|
* Side effects:
|
|||
|
* Cleans up the file handle table.
|
|||
|
*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static void
|
|||
|
FileExitProc(clientData)
|
|||
|
ClientData clientData; /* Not used. */
|
|||
|
{
|
|||
|
Tcl_HashSearch search;
|
|||
|
Tcl_HashEntry *entryPtr;
|
|||
|
|
|||
|
entryPtr = Tcl_FirstHashEntry(&fileTable, &search);
|
|||
|
|
|||
|
while (entryPtr) {
|
|||
|
ckfree(Tcl_GetHashValue(entryPtr));
|
|||
|
entryPtr = Tcl_NextHashEntry(&search);
|
|||
|
}
|
|||
|
|
|||
|
Tcl_DeleteHashTable(&fileTable);
|
|||
|
}
|
|||
|
#endif
|