diff options
-rwxr-xr-x | configure | 20 | ||||
-rw-r--r-- | configure.ac | 4 | ||||
-rw-r--r-- | jim-aio.c | 10 | ||||
-rw-r--r-- | jim-eventloop.c | 127 | ||||
-rw-r--r-- | jim-exec.c | 2 | ||||
-rw-r--r-- | jim-package.c | 20 | ||||
-rw-r--r-- | jim-regexp.c | 2 | ||||
-rw-r--r-- | jim-signal.c | 82 | ||||
-rw-r--r-- | jim.c | 66 | ||||
-rw-r--r-- | tcl6.tcl | 107 | ||||
-rw-r--r-- | tclcompat.tcl | 97 |
11 files changed, 238 insertions, 299 deletions
@@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.64 for jim 0.61. +# Generated by GNU Autoconf 2.64 for jim 0.62. # # Report bugs to <steveb@workware.net.au>. # @@ -548,8 +548,8 @@ MAKEFLAGS= # Identity of this package. PACKAGE_NAME='jim' PACKAGE_TARNAME='jim' -PACKAGE_VERSION='0.61' -PACKAGE_STRING='jim 0.61' +PACKAGE_VERSION='0.62' +PACKAGE_STRING='jim 0.62' PACKAGE_BUGREPORT='steveb@workware.net.au' PACKAGE_URL='' @@ -1173,7 +1173,7 @@ if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures jim 0.61 to adapt to many kinds of systems. +\`configure' configures jim 0.62 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1238,7 +1238,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of jim 0.61:";; + short | recursive ) echo "Configuration of jim 0.62:";; esac cat <<\_ACEOF @@ -1329,7 +1329,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -jim configure 0.61 +jim configure 0.62 generated by GNU Autoconf 2.64 Copyright (C) 2009 Free Software Foundation, Inc. @@ -1497,7 +1497,7 @@ cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by jim $as_me 0.61, which was +It was created by jim $as_me 0.62, which was generated by GNU Autoconf 2.64. Invocation command line was $ $0 $@ @@ -2767,7 +2767,7 @@ fi JIM_NOFORK=$JIM_NOFORK -jim_extensions="package readdir glob array clock exec file posix regexp signal tcl6 aio bio eventloop syslog" +jim_extensions="package readdir glob array clock exec file posix regexp signal tclcompat aio bio eventloop syslog" # Check whether --with-jim-ext was given. if test "${with_jim_ext+set}" = set; then : @@ -3418,7 +3418,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by jim $as_me 0.61, which was +This file was extended by jim $as_me 0.62, which was generated by GNU Autoconf 2.64. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -3469,7 +3469,7 @@ Report bugs to <steveb@workware.net.au>." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_version="\\ -jim config.status 0.61 +jim config.status 0.62 configured by $0, generated by GNU Autoconf 2.64, with options \\"`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\" diff --git a/configure.ac b/configure.ac index eaa20ee..8960438 100644 --- a/configure.ac +++ b/configure.ac @@ -2,7 +2,7 @@ # Process this file with autoconf to produce a configure script. AC_PREREQ(2.57) -AC_INIT([jim], [0.61], [steveb@workware.net.au]) +AC_INIT([jim], [0.62], [steveb@workware.net.au]) # Checks for programs. AC_PROG_CC @@ -30,7 +30,7 @@ AC_ARG_ENABLE(fork, ) AC_SUBST(JIM_NOFORK,$JIM_NOFORK) -jim_extensions="package readdir glob array clock exec file posix regexp signal tcl6 aio bio eventloop syslog" +jim_extensions="package readdir glob array clock exec file posix regexp signal tclcompat aio bio eventloop syslog" AC_ARG_WITH(jim-ext, [ --with-jim-ext Specify jim extensions to build (or all, which is the default)], [ @@ -60,14 +60,13 @@ #define AIO_BUF_LEN 1024 #define AIO_KEEPOPEN 1 -#define AIO_FDOPEN 2 typedef struct AioFile { FILE *fp; Jim_Obj *filename; int type; - int OpenFlags; /* AIO_KEEPOPEN? keep FILE*, AIO_FDOPEN? FILE* created via fdopen */ + int OpenFlags; /* AIO_KEEPOPEN? keep FILE* */ int fd; int flags; Jim_Obj *rEvent; @@ -101,9 +100,6 @@ static void JimAioDelProc(Jim_Interp *interp, void *privData) if (!(af->OpenFlags & AIO_KEEPOPEN)) { fclose(af->fp); } - if (!af->OpenFlags == AIO_FDOPEN) { - close(af->fd); - } #ifdef with_jim_ext_eventloop /* remove existing EventHandlers */ if (af->rEvent) { @@ -376,7 +372,7 @@ static int aio_cmd_accept(Jim_Interp *interp, int argc, Jim_Obj *const *argv) af->filename = Jim_NewStringObj(interp, "accept", -1); Jim_IncrRefCount(af->filename); af->fp = fdopen(sock,"r+"); - af->OpenFlags = AIO_FDOPEN; + af->OpenFlags = 0; af->flags = fcntl(af->fd,F_GETFL); af->rEvent = NULL; af->wEvent = NULL; @@ -706,7 +702,7 @@ static int JimMakeChannel(Jim_Interp *interp, Jim_Obj *filename, const char *hdl af = Jim_Alloc(sizeof(*af)); af->fp = fp; af->fd = fd; - af->OpenFlags = AIO_FDOPEN; + af->OpenFlags = 0; af->filename = filename; Jim_IncrRefCount(af->filename); af->flags = fcntl(af->fd, F_GETFL); diff --git a/jim-eventloop.c b/jim-eventloop.c index 60cafbb..b7520bb 100644 --- a/jim-eventloop.c +++ b/jim-eventloop.c @@ -45,17 +45,8 @@ * - Win32 port */ -#define JIM_EXTENSION -#define __JIM_EVENTLOOP_CORE__ -#ifdef __ECOS -#include <pkgconf/jimtcl.h> -#include <sys/time.h> -#include <cyg/jimtcl/jim.h> -#include <cyg/jimtcl/jim-eventloop.h> -#else #include "jim.h" #include "jim-eventloop.h" -#endif /* POSIX includes */ #include <sys/time.h> @@ -63,7 +54,6 @@ #include <unistd.h> #include <sys/select.h> #include <errno.h> - extern int errno; /* --- */ /* File event structure */ @@ -79,7 +69,7 @@ typedef struct Jim_FileEvent { /* Time event structure */ typedef struct Jim_TimeEvent { jim_wide id; /* time event identifier. */ - int mode; /* restart, repetitive .. UK */ + int mode; /* restart, repetitive .. UK */ long initialms; /* initial relativ timer value UK */ long when_sec; /* seconds */ long when_ms; /* milliseconds */ @@ -103,7 +93,6 @@ void Jim_CreateFileHandler(Jim_Interp *interp, void *handle, int mask, Jim_FileEvent *fe; Jim_EventLoop *eventLoop = Jim_GetAssocData(interp, "eventloop"); - // fprintf(stderr,"rein\n"); fe = Jim_Alloc(sizeof(*fe)); fe->handle = handle; fe->mask = mask; @@ -112,7 +101,6 @@ void Jim_CreateFileHandler(Jim_Interp *interp, void *handle, int mask, fe->clientData = clientData; fe->next = eventLoop->fileEventHead; eventLoop->fileEventHead = fe; - // fprintf(stderr,"raus\n"); } void Jim_DeleteFileHandler(Jim_Interp *interp, void *handle) @@ -137,16 +125,6 @@ void Jim_DeleteFileHandler(Jim_Interp *interp, void *handle) } } -// The same for signals. -void Jim_CreateSignalHandler(Jim_Interp *interp, int signum, - Jim_FileProc *proc, void *clientData, - Jim_EventFinalizerProc *finalizerProc) -{ -} -void Jim_DeleteSignalHandler(Jim_Interp *interp, int signum) -{ -} - /* That's another part of this extension that needs to be ported * to WIN32. */ static void JimGetTime(long *seconds, long *milliseconds) @@ -197,13 +175,14 @@ jim_wide Jim_DeleteTimeHandler(Jim_Interp *interp, jim_wide id) JimGetTime(&cur_sec, &cur_ms); te = eventLoop->timeEventHead; - if (id >= eventLoop->timeEventNextId) - return -2; /* wrong event ID */ + if (id >= eventLoop->timeEventNextId) { + return -2; /* wrong event ID */ + } while(te) { if (te->id == id) { remain = (te->when_sec - cur_sec) * 1000; remain += (te->when_ms - cur_ms) ; - remain = (remain < 0) ? 0 : remain ; + remain = (remain < 0) ? 0 : remain ; if (prev == NULL) eventLoop->timeEventHead = te->next; @@ -229,7 +208,7 @@ static Jim_TimeEvent *JimSearchNearestTimer(Jim_EventLoop *eventLoop) Jim_TimeEvent *te = eventLoop->timeEventHead; Jim_TimeEvent *nearest = NULL; - while(te) { + while (te) { if (!nearest || te->when_sec < nearest->when_sec || (te->when_sec == nearest->when_sec && te->when_ms < nearest->when_ms)) @@ -284,6 +263,7 @@ int Jim_ProcessEvents(Jim_Interp *interp, int flags) numfd++; fe = fe->next; } + /* Note that we want call select() even if there are no * file events to process as long as we want to process time * events, in order to sleep until the next time event is ready @@ -292,7 +272,7 @@ int Jim_ProcessEvents(Jim_Interp *interp, int flags) int retval; Jim_TimeEvent *shortest; struct timeval tv, *tvp; - jim_wide dt; + jim_wide dt; shortest = JimSearchNearestTimer(eventLoop); if (shortest) { @@ -302,33 +282,25 @@ int Jim_ProcessEvents(Jim_Interp *interp, int flags) * timer to fire. */ JimGetTime(&now_sec, &now_ms); tvp = &tv; - dt = 1000 * (shortest->when_sec - now_sec); - dt += ( shortest->when_ms - now_ms); + dt = 1000 * (shortest->when_sec - now_sec); + dt += ( shortest->when_ms - now_ms); if (dt < 0) { - dt = 1; - } - tvp->tv_sec = dt / 1000; - tvp->tv_usec = dt % 1000; - // fprintf(stderr,"Next %d.% 8d\n",(int)tvp->tv_sec,(int)tvp->tv_usec); + dt = 1; + } + tvp->tv_sec = dt / 1000; + tvp->tv_usec = dt % 1000; } else { tvp = NULL; /* wait forever */ - // fprintf(stderr,"No Event\n"); } retval = select(maxfd+1, &rfds, &wfds, &efds, tvp); if (retval < 0) { - switch (errno) { - case EINTR: fprintf(stderr,"select EINTR\n"); break; - case EINVAL: fprintf(stderr,"select EINVAL\n"); break; - case ENOMEM: fprintf(stderr,"select ENOMEM\n"); break; - } - } else if (retval > 0) { + /* XXX: Consider errno? EINTR? */ + } else if (retval > 0) { fe = eventLoop->fileEventHead; while(fe != NULL) { int fd = fileno(fe->handle); - // fprintf(stderr,"fd: %d mask: %02x \n",fd,fe->mask); - if ((fe->mask & JIM_EVENT_READABLE && FD_ISSET(fd, &rfds)) || (fe->mask & JIM_EVENT_WRITABLE && FD_ISSET(fd, &wfds)) || (fe->mask & JIM_EVENT_EXCEPTION && FD_ISSET(fd, &efds))) @@ -363,6 +335,7 @@ int Jim_ProcessEvents(Jim_Interp *interp, int flags) } } } + /* Check time events */ te = eventLoop->timeEventHead; maxId = eventLoop->timeEventNextId-1; @@ -395,6 +368,7 @@ int Jim_ProcessEvents(Jim_Interp *interp, int flags) return processed; } + /* ---------------------------------------------------------------------- */ void JimELAssocDataDeleProc(Jim_Interp *interp, void *data) @@ -481,41 +455,42 @@ static int JimELAfterCommand(Jim_Interp *interp, int argc, Jim_WrongNumArgs(interp, 1, argv, "<after milliseconds> script|cancel <id>"); return JIM_ERR; } - if (Jim_GetWide(interp, argv[1], &ms) != JIM_OK) + if (Jim_GetWide(interp, argv[1], &ms) != JIM_OK) { if (Jim_GetEnum(interp, argv[1], options, &option, "after options", - JIM_ERRMSG) != JIM_OK) + JIM_ERRMSG) != JIM_OK) { return JIM_ERR; + } + } switch (option) { - case CREATE: - Jim_IncrRefCount(argv[2]); - id = Jim_CreateTimeHandler(interp, ms, JimAfterTimeHandler, argv[2], - JimAfterTimeEventFinalizer); - objPtr = Jim_NewStringObj(interp, NULL, 0); - Jim_AppendString(interp, objPtr, "after#", -1); - idObjPtr = Jim_NewIntObj(interp, id); - Jim_IncrRefCount(idObjPtr); - Jim_AppendObj(interp, objPtr, idObjPtr); - Jim_DecrRefCount(interp, idObjPtr); - Jim_SetResult(interp, objPtr); - return JIM_OK; - case CANCEL: - { - int tlen ; - jim_wide remain = 0; - const char *tok = Jim_GetString(argv[2], &tlen); - if (sscanf(tok,"after#%" JIM_WIDE_MODIFIER, &id) == 1) { - remain = Jim_DeleteTimeHandler(interp, id); - if (remain > -2) { - Jim_SetResult(interp, Jim_NewIntObj(interp, remain)); - return JIM_OK; - } - } - Jim_SetResultString(interp, "invalid event" , -1); - return JIM_ERR; - } - default: - fprintf(stderr,"unserviced option to after %d\n",option); - } + case CREATE: + Jim_IncrRefCount(argv[2]); + id = Jim_CreateTimeHandler(interp, ms, JimAfterTimeHandler, argv[2], + JimAfterTimeEventFinalizer); + objPtr = Jim_NewStringObj(interp, NULL, 0); + Jim_AppendString(interp, objPtr, "after#", -1); + idObjPtr = Jim_NewIntObj(interp, id); + Jim_IncrRefCount(idObjPtr); + Jim_AppendObj(interp, objPtr, idObjPtr); + Jim_DecrRefCount(interp, idObjPtr); + Jim_SetResult(interp, objPtr); + return JIM_OK; + case CANCEL: { + int tlen ; + jim_wide remain = 0; + const char *tok = Jim_GetString(argv[2], &tlen); + if ( sscanf(tok,"after#%lld",&id) == 1) { + remain = Jim_DeleteTimeHandler(interp, id); + if (remain > -2) { + Jim_SetResult(interp, Jim_NewIntObj(interp, remain)); + return JIM_OK; + } + } + Jim_SetResultString(interp, "invalid event" , -1); + return JIM_ERR; + } + default: + fprintf(stderr,"unserviced option to after %d\n",option); + } return JIM_OK; } @@ -126,8 +126,8 @@ Jim_ExecCmd(Jim_Interp *interp, int argc, Jim_Obj *const *argv) if (result < 0) { Jim_SetResultErrno(interp, "error reading from output pipe"); } + close(outputId); } - close(outputId); if (Jim_CleanupChildren(interp, numPids, pidPtr, errorId) != JIM_OK) { result = JIM_ERR; diff --git a/jim-package.c b/jim-package.c index 264c95e..52818b8 100644 --- a/jim-package.c +++ b/jim-package.c @@ -160,13 +160,13 @@ int Jim_PackageRequire(Jim_Interp *interp, const char *name, int flags) * * package provide name ?version? * - * This procedure is invoked to declare that a particular version - * of a particular package is now present in an interpreter. There - * must not be any other version of this package already - * provided in the interpreter. + * This procedure is invoked to declare that a particular version + * of a particular package is now present in an interpreter. There + * must not be any other version of this package already + * provided in the interpreter. * * Results: - * Returns JIM_OK and sets the package version (or 1.0 if not specified). + * Returns JIM_OK and sets the package version (or 1.0 if not specified). * *---------------------------------------------------------------------- */ @@ -185,11 +185,11 @@ static int package_cmd_provide(Jim_Interp *interp, int argc, Jim_Obj *const *arg * * package require name ?version? * - * This procedure is load a given package. - * Note that the version is ignored. + * This procedure is load a given package. + * Note that the version is ignored. * * Results: - * Returns JIM_OK and sets the package version. + * Returns JIM_OK and sets the package version. * *---------------------------------------------------------------------- */ @@ -209,10 +209,10 @@ static int package_cmd_require(Jim_Interp *interp, int argc, Jim_Obj *const *arg * * package list * - * Returns a list of known packages + * Returns a list of known packages * * Results: - * Returns JIM_OK and sets a list of known packages. + * Returns JIM_OK and sets a list of known packages. * *---------------------------------------------------------------------- */ diff --git a/jim-regexp.c b/jim-regexp.c index 3c36ae9..deffb50 100644 --- a/jim-regexp.c +++ b/jim-regexp.c @@ -238,8 +238,6 @@ int Jim_RegexpCmd(Jim_Interp *interp, int argc, Jim_Obj *const *argv) * index information in those variables. */ - //fprintf(stderr, "source_str=%s, [0].rm_eo=%d\n", source_str, pmatch[0].rm_eo); - j = 0; for (i += 2; opt_inline ? pmatch[j].rm_so != -1 : i < argc; i++, j++) { Jim_Obj *resultObj; diff --git a/jim-signal.c b/jim-signal.c index 7eb4a1f..e55134c 100644 --- a/jim-signal.c +++ b/jim-signal.c @@ -37,15 +37,15 @@ static void signal_ignorer(int sig) * * Tcl_SignalId -- * - * Return a textual identifier for a signal number. + * Return a textual identifier for a signal number. * * Results: - * This procedure returns a machine-readable textual identifier - * that corresponds to sig. The identifier is the same as the - * #define name in signal.h. + * This procedure returns a machine-readable textual identifier + * that corresponds to sig. The identifier is the same as the + * #define name in signal.h. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ @@ -54,112 +54,112 @@ const char *Jim_SignalId(int sig) { switch (sig) { #ifdef SIGABRT - case SIGABRT: return "SIGABRT"; + case SIGABRT: return "SIGABRT"; #endif #ifdef SIGALRM - case SIGALRM: return "SIGALRM"; + case SIGALRM: return "SIGALRM"; #endif #ifdef SIGBUS - case SIGBUS: return "SIGBUS"; + case SIGBUS: return "SIGBUS"; #endif #ifdef SIGCHLD - case SIGCHLD: return "SIGCHLD"; + case SIGCHLD: return "SIGCHLD"; #endif #if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) - case SIGCLD: return "SIGCLD"; + case SIGCLD: return "SIGCLD"; #endif #ifdef SIGCONT - case SIGCONT: return "SIGCONT"; + case SIGCONT: return "SIGCONT"; #endif #if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) - case SIGEMT: return "SIGEMT"; + case SIGEMT: return "SIGEMT"; #endif #ifdef SIGFPE - case SIGFPE: return "SIGFPE"; + case SIGFPE: return "SIGFPE"; #endif #ifdef SIGHUP - case SIGHUP: return "SIGHUP"; + case SIGHUP: return "SIGHUP"; #endif #ifdef SIGILL - case SIGILL: return "SIGILL"; + case SIGILL: return "SIGILL"; #endif #ifdef SIGINT - case SIGINT: return "SIGINT"; + case SIGINT: return "SIGINT"; #endif #ifdef SIGIO - case SIGIO: return "SIGIO"; + case SIGIO: return "SIGIO"; #endif #if defined(SIGIOT) && (!defined(SIGABRT) || (SIGIOT != SIGABRT)) - case SIGIOT: return "SIGIOT"; + case SIGIOT: return "SIGIOT"; #endif #ifdef SIGKILL - case SIGKILL: return "SIGKILL"; + case SIGKILL: return "SIGKILL"; #endif #if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) - case SIGLOST: return "SIGLOST"; + case SIGLOST: return "SIGLOST"; #endif #ifdef SIGPIPE - case SIGPIPE: return "SIGPIPE"; + case SIGPIPE: return "SIGPIPE"; #endif #if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) - case SIGPOLL: return "SIGPOLL"; + case SIGPOLL: return "SIGPOLL"; #endif #ifdef SIGPROF - case SIGPROF: return "SIGPROF"; + case SIGPROF: return "SIGPROF"; #endif #if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) - case SIGPWR: return "SIGPWR"; + case SIGPWR: return "SIGPWR"; #endif #ifdef SIGQUIT - case SIGQUIT: return "SIGQUIT"; + case SIGQUIT: return "SIGQUIT"; #endif #ifdef SIGSEGV - case SIGSEGV: return "SIGSEGV"; + case SIGSEGV: return "SIGSEGV"; #endif #ifdef SIGSTOP - case SIGSTOP: return "SIGSTOP"; + case SIGSTOP: return "SIGSTOP"; #endif #ifdef SIGSYS - case SIGSYS: return "SIGSYS"; + case SIGSYS: return "SIGSYS"; #endif #ifdef SIGTERM - case SIGTERM: return "SIGTERM"; + case SIGTERM: return "SIGTERM"; #endif #ifdef SIGTRAP - case SIGTRAP: return "SIGTRAP"; + case SIGTRAP: return "SIGTRAP"; #endif #ifdef SIGTSTP - case SIGTSTP: return "SIGTSTP"; + case SIGTSTP: return "SIGTSTP"; #endif #ifdef SIGTTIN - case SIGTTIN: return "SIGTTIN"; + case SIGTTIN: return "SIGTTIN"; #endif #ifdef SIGTTOU - case SIGTTOU: return "SIGTTOU"; + case SIGTTOU: return "SIGTTOU"; #endif #if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) - case SIGURG: return "SIGURG"; + case SIGURG: return "SIGURG"; #endif #ifdef SIGUSR1 - case SIGUSR1: return "SIGUSR1"; + case SIGUSR1: return "SIGUSR1"; #endif #ifdef SIGUSR2 - case SIGUSR2: return "SIGUSR2"; + case SIGUSR2: return "SIGUSR2"; #endif #ifdef SIGVTALRM - case SIGVTALRM: return "SIGVTALRM"; + case SIGVTALRM: return "SIGVTALRM"; #endif #ifdef SIGWINCH - case SIGWINCH: return "SIGWINCH"; + case SIGWINCH: return "SIGWINCH"; #endif #ifdef SIGXCPU - case SIGXCPU: return "SIGXCPU"; + case SIGXCPU: return "SIGXCPU"; #endif #ifdef SIGXFSZ - case SIGXFSZ: return "SIGXFSZ"; + case SIGXFSZ: return "SIGXFSZ"; #endif #ifdef SIGINFO - case SIGINFO: return "SIGINFO"; + case SIGINFO: return "SIGINFO"; #endif } return "unknown signal"; @@ -515,12 +515,6 @@ unsigned int Jim_IntHashFunction(unsigned int key) return key; } -/* Identity hash function for integer keys */ -unsigned int Jim_IdentityHashFunction(unsigned int key) -{ - return key; -} - /* Generic hash function (we are using to multiply by 9 and add the byte * as Tcl) */ unsigned int Jim_GenHashFunction(const unsigned char *buf, int len) @@ -1927,16 +1921,6 @@ void StringAppendString(Jim_Obj *objPtr, const char *str, int len) objPtr->length += len; } -/* Low-level wrapper to append an object. */ -void StringAppendObj(Jim_Obj *objPtr, Jim_Obj *appendObjPtr) -{ - int len; - const char *str; - - str = Jim_GetString(appendObjPtr, &len); - StringAppendString(objPtr, str, len); -} - /* Higher level API to append strings to objects. */ void Jim_AppendString(Jim_Interp *interp, Jim_Obj *objPtr, const char *str, int len) @@ -3857,14 +3841,6 @@ unsigned int JimReferencesHTHashFunction(const void *key) return Jim_IntHashFunction(intValue); } -unsigned int JimReferencesHTDoubleHashFunction(const void *key) -{ - /* Only the least significant bits are used. */ - const jim_wide *widePtr = key; - unsigned int intValue = (unsigned int) *widePtr; - return intValue; /* identity function. */ -} - const void *JimReferencesHTKeyDup(void *privdata, const void *key) { void *copy = Jim_Alloc(sizeof(jim_wide)); @@ -4290,15 +4266,6 @@ Jim_Interp *Jim_CreateInterp(void) return i; } -/* This is the only function Jim exports directly without - * to use the STUB system. It is only used by embedders - * in order to get an interpreter with the Jim API pointers - * registered. */ -Jim_Interp *ExportedJimCreateInterp(void) -{ - return Jim_CreateInterp(); -} - void Jim_FreeInterp(Jim_Interp *i) { Jim_CallFrame *cf = i->framePtr, *prevcf, *nextcf; @@ -5349,6 +5316,7 @@ int Jim_ListIndex(Jim_Interp *interp, Jim_Obj *listPtr, int index, Jim_SetResultString(interp, "list index out of range", -1); } + *objPtrPtr = NULL; return JIM_ERR; } if (index < 0) @@ -6228,6 +6196,8 @@ static int expr_getnum(Jim_Interp *interp, struct expr_state *e, Jim_Obj **resul Jim_Obj *obj = expr_pop(e); *resultObjPtr = obj; + *w = 0; + *d = 0; /* If it is already an integer or double, use it */ if (obj->typePtr == &intObjType) { @@ -7245,7 +7215,7 @@ static void ExprMakeLazy(Jim_Interp *interp, ExprByteCode *expr) || expr->opcode[i] == JIM_EXPROP_TERNARY_LEFT || expr->opcode[i] == JIM_EXPROP_COLON_LEFT ) { - long skip; + long skip = 0; Jim_GetLong(interp, expr->obj[i - 1], &skip); if (skip + i - 1 >= leftindex) { @@ -10324,9 +10294,9 @@ static int Jim_LsearchCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv) { static const char *options[] = { - "-bool", "-not", "-nocase", "-exact", "-glob", "-regexp", "-all", "-inline", NULL + "-bool", "-not", "-nocase", "-exact", "-glob", "-regexp", "-all", "-inline", "-command", NULL }; - enum {OPT_BOOL, OPT_NOT, OPT_NOCASE, OPT_EXACT, OPT_GLOB, OPT_REGEXP, OPT_ALL, OPT_INLINE, OPT_INTEGER}; + enum {OPT_BOOL, OPT_NOT, OPT_NOCASE, OPT_EXACT, OPT_GLOB, OPT_REGEXP, OPT_ALL, OPT_INLINE, OPT_COMMAND }; int i; int opt_bool = 0; int opt_not = 0; @@ -10337,10 +10307,11 @@ static int Jim_LsearchCoreCommand(Jim_Interp *interp, int argc, int listlen; int rc = JIM_OK; Jim_Obj *listObjPtr = NULL; - Jim_Obj *regexpCommandObj = NULL; + Jim_Obj *commandObj = NULL; if (argc < 3) { - Jim_WrongNumArgs(interp, 1, argv, "?-exact|-glob|-regexp? ?-bool|-inline? ?-not? ?-nocase? ?-all? list value"); +wrongargs: + Jim_WrongNumArgs(interp, 1, argv, "?-exact|-glob|-regexp|-command 'command'? ?-bool|-inline? ?-not? ?-nocase? ?-all? list value"); return JIM_ERR; } @@ -10356,6 +10327,12 @@ static int Jim_LsearchCoreCommand(Jim_Interp *interp, int argc, case OPT_NOCASE: opt_nocase = 1; break; case OPT_INLINE: opt_inline = 1; opt_bool = 0; break; case OPT_ALL: opt_all = 1; break; + case OPT_COMMAND: + if (i >= argc - 2) { + goto wrongargs; + } + commandObj = argv[++i]; + /* fallthru */ case OPT_EXACT: case OPT_GLOB: case OPT_REGEXP: @@ -10370,8 +10347,10 @@ static int Jim_LsearchCoreCommand(Jim_Interp *interp, int argc, listObjPtr = Jim_NewListObj(interp, NULL, 0); } if (opt_match == OPT_REGEXP) { - regexpCommandObj = Jim_NewStringObj(interp, "regexp", -1); - Jim_IncrRefCount(regexpCommandObj); + commandObj = Jim_NewStringObj(interp, "regexp", -1); + } + if (commandObj) { + Jim_IncrRefCount(commandObj); } Jim_ListLength(interp, argv[0], &listlen); @@ -10389,7 +10368,8 @@ static int Jim_LsearchCoreCommand(Jim_Interp *interp, int argc, break; case OPT_REGEXP: - eq = Jim_CommandMatchObj(interp, regexpCommandObj, argv[1], objPtr, opt_nocase); + case OPT_COMMAND: + eq = Jim_CommandMatchObj(interp, commandObj, argv[1], objPtr, opt_nocase); if (eq < 0) { if (listObjPtr) { Jim_FreeNewObj(interp, listObjPtr); @@ -10443,8 +10423,8 @@ static int Jim_LsearchCoreCommand(Jim_Interp *interp, int argc, } done: - if (regexpCommandObj) { - Jim_DecrRefCount(interp, regexpCommandObj); + if (commandObj) { + Jim_DecrRefCount(interp, commandObj); } return rc; } @@ -1,107 +0,0 @@ -# (c) 2008 Steve Bennett <steveb@workware.net.au> -# -# Loads a Tcl6-compatible environment plus some newer features, -# including stdio, array, file, clock, glob, regexp, regsub, lsearch, case, ::env - -package provide tcl6 1.0 - -# Set up the ::env array -set env [env] - -# Tcl 8.5 lassign -proc lassign {list args} { - uplevel 1 [list foreach $args [concat $list {}] break] - lrange $list [llength $args] end -} - -# Internal function to match a value agains a list of patterns -proc _case_search_patterns {patterns value} { - set i 0 - foreach pattern $patterns { - if {[string match $pattern $value]} { - return $i - } - incr i - } - return -1 -} - -# case var ?in? pattern action ?pattern action ...? -proc case {var args} { - # Skip dummy parameter - if {[lindex $args 0] eq "in"} { - set args [lrange $args 1 end] - } - - # Check for single arg form - if {[llength $args] == 1} { - set args [lindex $args 0] - } - - # Check for odd number of args - if {[llength $args] % 2 != 0} { - error "extra case pattern with no body" - } - - #puts "looking for $var in '$args'" - foreach {value action} $args { - if {$value eq "default"} { - set do_action $action - continue - } else { - if {[_case_search_patterns $value $var] >= 0} { - set do_action $action - break - } - } - } - - if {[info exists do_action]} { - set rc [catch [list uplevel 1 $do_action] result] - return -code $rc $result - } -} - -# Optional argument is a glob pattern -proc parray {arrayname {pattern *}} { - upvar $arrayname a - - set max 0 - foreach name [array names a $pattern]] { - if {[string length $name] > $max} { - set max [string length $name] - } - } - incr max [string length $arrayname] - incr max 2 - foreach name [lsort [array names a $pattern]] { - puts [format "%-${max}s = %s" $arrayname\($name\) $a($name)] - } -} - -# Sort of replacement for $::errorInfo -# Usage: errorInfo error ?stacktrace? -proc errorInfo {error {stacktrace ""}} { - if {$stacktrace eq ""} { - set stacktrace [info stacktrace] - } - set result "Runtime Error: $error" - foreach {l f p} [lreverse $stacktrace] { - append result \n - if {$p ne ""} { - append result "in procedure '$p' " - if {$f ne ""} { - append result "called " - } - } - if {$f ne ""} { - append result "at file \"$f\", line $l" - } - } - if {[info exists f] && $f ne ""} { - return "$f:$l: $result" - } - return $result -} - -set ::tcl_platform(platform) unix diff --git a/tclcompat.tcl b/tclcompat.tcl new file mode 100644 index 0000000..bb59f38 --- /dev/null +++ b/tclcompat.tcl @@ -0,0 +1,97 @@ +# (c) 2008 Steve Bennett <steveb@workware.net.au> +# +# Loads some Tcl-compatible features. +# case, lassign, parray, errorInfo, ::tcl_platform, ::env + +package provide tclcompat 1.0 + +# Set up the ::env array +set env [env] + +# Tcl 8.5 lassign +proc lassign {list args} { + uplevel 1 [list foreach $args [concat $list {}] break] + lrange $list [llength $args] end +} + +# case var ?in? pattern action ?pattern action ...? +proc case {var args} { + # Skip dummy parameter + if {[lindex $args 0] eq "in"} { + set args [lrange $args 1 end] + } + + # Check for single arg form + if {[llength $args] == 1} { + set args [lindex $args 0] + } + + # Check for odd number of args + if {[llength $args] % 2 != 0} { + error "extra case pattern with no body" + } + + # Internal function to match a value agains a list of patterns + set checker [lambda {value pattern} {string match $pattern $value}] + + foreach {value action} $args { + if {$value eq "default"} { + set do_action $action + continue + } elseif {[lsearch -bool -command $checker $value $var]} { + set do_action $action + break + } + } + + rename $checker "" + + if {[info exists do_action]} { + set rc [catch [list uplevel 1 $do_action] result] + return -code $rc $result + } +} + +# Optional argument is a glob pattern +proc parray {arrayname {pattern *}} { + upvar $arrayname a + + set max 0 + foreach name [array names a $pattern]] { + if {[string length $name] > $max} { + set max [string length $name] + } + } + incr max [string length $arrayname] + incr max 2 + foreach name [lsort [array names a $pattern]] { + puts [format "%-${max}s = %s" $arrayname\($name\) $a($name)] + } +} + +# Sort of replacement for $::errorInfo +# Usage: errorInfo error ?stacktrace? +proc errorInfo {error {stacktrace ""}} { + if {$stacktrace eq ""} { + set stacktrace [info stacktrace] + } + set result "Runtime Error: $error" + foreach {l f p} [lreverse $stacktrace] { + append result \n + if {$p ne ""} { + append result "in procedure '$p' " + if {$f ne ""} { + append result "called " + } + } + if {$f ne ""} { + append result "at file \"$f\", line $l" + } + } + if {[info exists f] && $f ne ""} { + return "$f:$l: $result" + } + return $result +} + +set ::tcl_platform(platform) unix |