diff --git a/ChangeLog b/ChangeLog index 5f57792..0d04bba 100644 --- a/ChangeLog +++ b/ChangeLog @@ -327,7 +327,7 @@ 2010-04-01 Zoran Vasiljevic - * generic/tclXkeylist.c: Removed declaration of global TclX keylist + * generic/tclXkeylist.c: Removed declaration of global TclX keylist commands. 2010-03-30 Zoran Vasiljevic @@ -346,17 +346,17 @@ 2010-03-19 Jan Nijtmans - * generic/threadSpCmd.c: Silence gcc warning: dereferencing - * .cvsignore: type-punned pointer will break + * generic/threadSpCmd.c: Silence gcc warning: dereferencing + * .cvsignore: type-punned pointer will break strict-aliasing rules. - * configure: Regenerated using latest TEA + * configure: Regenerated using latest TEA 2009-08-19 Zoran Vasiljevic * generic/threadPoolCmd.c: Implemented [tpool::suspend] * doc/tpool.man: and [tpool::resume] commands - as per [RFE #2835615]. - Also fixed [Bug #2833864]. + as per [RFE #2835615]. + Also fixed [Bug #2833864]. 2009-07-22 Jan Nijtmans @@ -606,13 +606,13 @@ source and target thread ID's for the detached channel to zero, thus signalizing the cleanup code to leave the channel in the cleanup-list when the - thread who detached it exits. + thread who detached it exits. 2005-08-24 Zoran Vasiljevic * generic/tclXkeylist.c: made some calls static so they do not interfere for static linking with - certain extensions. + certain extensions. 2005-08-08 Zoran Vasiljevic @@ -718,7 +718,7 @@ * lib/ttrace.tcl: added [ttrace::config] to control some runtime options. The only option it allows now is "-doepochs". This is a boolean flag turning the - epoch generation off/on. + epoch generation off/on. Also, improved handling of XOTcl introspections in regard to namespaced objects/classes. @@ -731,7 +731,7 @@ 2005-01-03 Zoran Vasiljevic - **** RELEASE: 2.6.1 Tagged **** + **** RELEASE: 2.6.1 Tagged **** * aolserver.m4: * configure.in: @@ -755,7 +755,7 @@ 2004-12-23 Zoran Vasiljevic - **** RELEASE: 2.6 Tagged **** + **** RELEASE: 2.6 Tagged **** * tcl/cmdsrv/cmdsrv.tcl: example command server listens on loopback interface (127.0.0.1) only @@ -797,7 +797,7 @@ * tests/thread.tcl: Disabled all tests handling channel transfer for Windows ports until core is capable of handling this correctly. - * generic/threadSpCmd.c: Fixed segmentation problems observed on + * generic/threadSpCmd.c: Fixed segmentation problems observed on Windows ports and related to notification of an uninitialized condition variable(s). This closes Bug #1051068 (wrongly posted under Tcl Patches at SF). @@ -912,8 +912,8 @@ 2004-01-31 Zoran Vasiljevic * generic/threadCmd.c: fixed incorrect handling of return - codes from the scripts passed to threads. We were wrongly - triggering error for non-error return codes such as TCL_RETURN, + codes from the scripts passed to threads. We were wrongly + triggering error for non-error return codes such as TCL_RETURN, TCL_BREAK, TCL_CONTINUE etc. Now we trigger error only for TCL_ERROR and return other codes (as-is) to the caller. This also fixes the Tcl Bug #884549. @@ -1016,7 +1016,7 @@ * generic/threadPoolCmd.c: added "-nowait" option to the "tpool::post" commandi. This allows the - caller to post jobs to the threadpool queue without + caller to post jobs to the threadpool queue without waiting for an idle thread. The implementation will start at least one worker thread if there is none available to satisfy the first request. @@ -1037,13 +1037,13 @@ 2003-04-29 Zoran Vasiljevic - Tagged interim 2.5.2 release. + Tagged interim 2.5.2 release. * configure.in * configure: Added quick fix for autoconf issues - related to $srcdir and building of the package - from the top-level dir instead of unix/win subdir. - Thanks to Mo DeJong for the fix. + related to $srcdir and building of the package + from the top-level dir instead of unix/win subdir. + Thanks to Mo DeJong for the fix. 2003-04-10 Zoran Vasiljevic @@ -1150,8 +1150,8 @@ * generic/threadPoolCmd.c: fixed one missing mutex unlock in the ThreadRelease. - * tcl/tpool/tpool.tcl: implemented missing API calls found - in the C-level implementation. + * tcl/tpool/tpool.tcl: implemented missing API calls found + in the C-level implementation. * tcl/phttpd/phttpd.tcl: simplified switching to Tcl-level threadpool implementation. @@ -1173,7 +1173,7 @@ prefix for mutex/cond commands. * generic/threadCmd.c: rewritten to use SpliceIn/SpliceOut - macros instead of hand-fiddling with linked lists. + macros instead of hand-fiddling with linked lists. * generic/threadPoolCmd.c: new file @@ -1275,12 +1275,12 @@ 2002-07-20 Mo DeJong - * generic/threadSvCmd.c (Sv_tclEmptyStringRep, Sv_Init): - Avoid linking to the tclEmptyStringRep variable defined - in Tcl since this makes it very difficult to load - the Thread package into an executable that has - also loaded Tcl. The previous approach used a hack - under Windows, we now use this same hack on all systems. + * generic/threadSvCmd.c (Sv_tclEmptyStringRep, Sv_Init): + Avoid linking to the tclEmptyStringRep variable defined + in Tcl since this makes it very difficult to load + the Thread package into an executable that has + also loaded Tcl. The previous approach used a hack + under Windows, we now use this same hack on all systems. [Tcl patch 584123] 2002-07-19 Zoran Vasiljevic @@ -1296,7 +1296,7 @@ the thread waiting until the target thread has really exited. Otherwise, the command exits immediately and target thread may exit asynchronously some time later. - This is not techically needed since one can always join + This is not techically needed since one can always join the exiting thread, but the join command is not available for some older Tcl versions. @@ -1315,11 +1315,11 @@ 2002-07-09 Zoran Vasiljevic * README: added this file - * license.terms: added this file + * license.terms: added this file 2002-07-05 Zoran Vasiljevic - * tclconfig/tcl.m4: fixed reference to MINGW so we can + * tclconfig/tcl.m4: fixed reference to MINGW so we can compile w/o MSVC under windows. 2002-07-03 Zoran Vasiljevic @@ -1467,8 +1467,8 @@ running. * generic/threadCmd.c: added conditional setup of the command - prefix. Now, the "NS" can be used to select the command prefix - for thread::* commands. + prefix. Now, the "NS" can be used to select the command prefix + for thread::* commands. 2002-01-26 David Gravereaux @@ -1498,29 +1498,29 @@ 2002-01-02 Zoran Vasiljevic - * generic/threadSvListCmd.* (new): added for the new implementation - of the thread-shared-variable (tsv) interface. - * generic/threadSvCmd.c: now uses shared Tcl objects instead of strings - for storing data in shared arrays. This improves performance on large - shared data structures. - Added new tsv::* syntax, per request. This replaces older thread::sv_* - interface. Older commands are still present but will be removed as - soon we hit the 3.0 version. - * generic/threadCmd.c: revamped to support asynchronous backfiring - of scripts so we can vwait on the results of thread processing. - This also corrected the bug #464340. Affected command is thread::send. - * doc/thread.n: added docs for all thread::* and tsv::* commands. - This fixes #416850 bug report. The html/tmml files are still out of date. - * configure: built with autoconf 2.52 - * config/config.guess (new): needed for the new configure - * config/config.sub (new): needed for the new configure - * Makefile.in: added lines for new generic/threadSvListCmd.c - * configure.in: moving to 2.4 version. - * unix/threadUnix.c: removed traces of ThreadKill. It is still not clear - wether we should implement this functionality or not. - * win/threadWin.c: see above. - * pkgIndex.tcl.in: fixed to correctly handle version for different Tcl core - versions. + * generic/threadSvListCmd.* (new): added for the new implementation + of the thread-shared-variable (tsv) interface. + * generic/threadSvCmd.c: now uses shared Tcl objects instead of strings + for storing data in shared arrays. This improves performance on large + shared data structures. + Added new tsv::* syntax, per request. This replaces older thread::sv_* + interface. Older commands are still present but will be removed as + soon we hit the 3.0 version. + * generic/threadCmd.c: revamped to support asynchronous backfiring + of scripts so we can vwait on the results of thread processing. + This also corrected the bug #464340. Affected command is thread::send. + * doc/thread.n: added docs for all thread::* and tsv::* commands. + This fixes #416850 bug report. The html/tmml files are still out of date. + * configure: built with autoconf 2.52 + * config/config.guess (new): needed for the new configure + * config/config.sub (new): needed for the new configure + * Makefile.in: added lines for new generic/threadSvListCmd.c + * configure.in: moving to 2.4 version. + * unix/threadUnix.c: removed traces of ThreadKill. It is still not clear + wether we should implement this functionality or not. + * win/threadWin.c: see above. + * pkgIndex.tcl.in: fixed to correctly handle version for different Tcl core + versions. 2001-09-05 David Gravereaux @@ -1688,8 +1688,8 @@ 2000-10-16 Zoran Vasiljevic * generic/threadSvCmd.c ThreadSvUnsetObjCmd(): deadlocked. - Forgot to release shared-array lock which resulted in - deadlock after first successful unset of the variable. + Forgot to release shared-array lock which resulted in + deadlock after first successful unset of the variable. 2000-08-29 David Gravereaux @@ -1783,7 +1783,7 @@ 2000-07-03 Zoran Vasiljevic - Summary of changes: + Summary of changes: * generic/threadSpCmd.c: new file with implementation of "thread::mutex" and "thread::cond" commands. Documentation @@ -1805,19 +1805,19 @@ Added "thread::exists" command. Moved most of internal functions in threadCmd.c to statics, - except the Thread*ObjCmd(). + except the Thread*ObjCmd(). Changed behaviour of "thread::exit". It now simply flips the - bit to signal thread stuck in thread::wait to gracefuly exit. - Consequence: command now does not trigger error on thread exit. - Also, thread event queue is now properly cleared. - ThreadWait() and ThreadStop() are newly added to support this. - Also the ThreadSpecificData has one more integer: "stopped" + bit to signal thread stuck in thread::wait to gracefuly exit. + Consequence: command now does not trigger error on thread exit. + Also, thread event queue is now properly cleared. + ThreadWait() and ThreadStop() are newly added to support this. + Also the ThreadSpecificData has one more integer: "stopped" Replaced ref's to obsolete Tcl_GlobalEval() with Tcl_EvalEx(). Fixed broken 'thread::create -joinable script'; - was missing initialization of script variable + was missing initialization of script variable Added calls to initialize new commands in threadSpCmd.c and threadSvCmd.c files. diff --git a/Makefile.in b/Makefile.in index 1e479ab..e3e9063 100644 --- a/Makefile.in +++ b/Makefile.in @@ -323,7 +323,7 @@ $(PKG_LIB_FILE): $(PKG_OBJECTS) ${THREAD_ZIP_FILE} if test "x$(MACHER)" = "x" ; then \ cat ${THREAD_ZIP_FILE} >> ${PKG_LIB_FILE}; \ else $(MACHER) append ${PKG_LIB_FILE} ${THREAD_ZIP_FILE} /tmp/macher_output; \ - mv /tmp/macher_output ${PKG_LIB_FILE}; chmod u+x ${PKG_LIB_FILE}; \ + mv /tmp/macher_output ${PKG_LIB_FILE}; chmod u+x ${PKG_LIB_FILE}; \ fi; \ ${NATIVE_ZIP} -A ${PKG_LIB_FILE} \ || echo 'ignore zip-error by adjust sfx process (not executable?)'; \ @@ -342,7 +342,7 @@ $(PKG_STUB_LIB_FILE): $(PKG_STUB_OBJECTS) # you will have to modify the paths to reflect this: # # sample.$(OBJEXT): $(srcdir)/generic/sample.c -# $(COMPILE) -c `@CYGPATH@ $(srcdir)/generic/sample.c` -o $@ +# $(COMPILE) -c `@CYGPATH@ $(srcdir)/generic/sample.c` -o $@ # # Setting the VPATH variable to a list of paths will cause the makefile # to look into these paths when resolving .c to .obj dependencies. @@ -475,7 +475,7 @@ install-lib-binaries: binaries lib=`basename $$p|sed -e 's/.[^.]*$$//'`.lib; \ if test -f $$lib; then \ echo " $(INSTALL_DATA) $$lib $(DESTDIR)$(pkglibdir)/$$lib"; \ - $(INSTALL_DATA) $$lib "$(DESTDIR)$(pkglibdir)/$$lib"; \ + $(INSTALL_DATA) $$lib "$(DESTDIR)$(pkglibdir)/$$lib"; \ fi; \ fi; \ fi; \ diff --git a/README b/README index 43778df..e5004e8 100644 --- a/README +++ b/README @@ -46,7 +46,7 @@ HOW TO GET SUPPORT ? The extension is maintained, enhanced, and distributed freely by the Tcl community. The home for sources and bug/patch database is on fossil: - https://core.tcl-lang.org/thread + https://core.tcl-lang.org/thread Alternatively, you are always welcome to post your questions, problems and/or suggestions relating the extension (or any other Tcl issue) diff --git a/aclocal.m4 b/aclocal.m4 index 995e3a2..5375a29 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -28,45 +28,45 @@ AC_DEFUN(TCLTHREAD_WITH_GDBM, [ AC_CACHE_VAL(ac_cv_c_gdbm,[ if test x"${with_gdbm}" != x -a "${with_gdbm}" != "yes"; then - if test -f "${with_gdbm}/gdbm.h" -a x"`ls ${with_gdbm}/libgdbm* 2>/dev/null`" != x; then - ac_cv_c_gdbm=`(cd ${with_gdbm}; pwd)` - gincdir=$ac_cv_c_gdbm - glibdir=$ac_cv_c_gdbm - AC_MSG_RESULT([found in $glibdir]) - else - AC_MSG_ERROR([${with_gdbm} directory doesn't contain gdbm library]) - fi + if test -f "${with_gdbm}/gdbm.h" -a x"`ls ${with_gdbm}/libgdbm* 2>/dev/null`" != x; then + ac_cv_c_gdbm=`(cd ${with_gdbm}; pwd)` + gincdir=$ac_cv_c_gdbm + glibdir=$ac_cv_c_gdbm + AC_MSG_RESULT([found in $glibdir]) + else + AC_MSG_ERROR([${with_gdbm} directory doesn't contain gdbm library]) + fi fi ]) if test x"${gincdir}" = x -o x"${glibdir}" = x; then - for i in \ - `ls -d ${exec_prefix}/lib 2>/dev/null`\ - `ls -d ${prefix}/lib 2>/dev/null`\ - `ls -d /usr/local/lib 2>/dev/null`\ - `ls -d /usr/lib 2>/dev/null`\ - `ls -d /usr/lib/x86_64-linux-gnu 2>/dev/null` ; do - if test x"`ls $i/libgdbm* 2>/dev/null`" != x ; then - glibdir=`(cd $i; pwd)` - break - fi - done - for i in \ - `ls -d ${prefix}/include 2>/dev/null`\ - `ls -d /usr/local/include 2>/dev/null`\ - `ls -d /usr/include 2>/dev/null` ; do - if test -f "$i/gdbm.h" ; then - gincdir=`(cd $i; pwd)` - break - fi - done - if test x"$glibdir" = x -o x"$gincdir" = x ; then - AC_MSG_ERROR([none found]) - else - AC_MSG_RESULT([found in $glibdir, includes in $gincdir]) - AC_DEFINE(HAVE_GDBM) - GDBM_CFLAGS="-I\"$gincdir\"" - GDBM_LIBS="-L\"$glibdir\" -lgdbm" - fi + for i in \ + `ls -d ${exec_prefix}/lib 2>/dev/null`\ + `ls -d ${prefix}/lib 2>/dev/null`\ + `ls -d /usr/local/lib 2>/dev/null`\ + `ls -d /usr/lib 2>/dev/null`\ + `ls -d /usr/lib/x86_64-linux-gnu 2>/dev/null` ; do + if test x"`ls $i/libgdbm* 2>/dev/null`" != x ; then + glibdir=`(cd $i; pwd)` + break + fi + done + for i in \ + `ls -d ${prefix}/include 2>/dev/null`\ + `ls -d /usr/local/include 2>/dev/null`\ + `ls -d /usr/include 2>/dev/null` ; do + if test -f "$i/gdbm.h" ; then + gincdir=`(cd $i; pwd)` + break + fi + done + if test x"$glibdir" = x -o x"$gincdir" = x ; then + AC_MSG_ERROR([none found]) + else + AC_MSG_RESULT([found in $glibdir, includes in $gincdir]) + AC_DEFINE(HAVE_GDBM) + GDBM_CFLAGS="-I\"$gincdir\"" + GDBM_LIBS="-L\"$glibdir\" -lgdbm" + fi fi fi ]) @@ -88,49 +88,49 @@ AC_DEFUN(TCLTHREAD_WITH_LMDB, [ with_lmdb=${withval}) if test x"${with_lmdb}" != "x" -a "${with_lmdb}" != no; then - AC_MSG_CHECKING([for LMDB library]) - AC_CACHE_VAL(ac_cv_c_lmdb,[ - if test x"${with_lmdb}" != x -a "${with_lmdb}" != "yes"; then - if test -f "${with_lmdb}/lmdb.h" -a x"`ls ${with_lmdb}/liblmdb* 2>/dev/null`" != x; then - ac_cv_c_lmdb=`(cd ${with_lmdb}; pwd)` - lincdir=$ac_cv_c_lmdb - llibdir=$ac_cv_c_lmdb - AC_MSG_RESULT([found in $llibdir]) - else - AC_MSG_ERROR([${with_lmdb} directory doesn't contain lmdb library]) - fi - fi - ]) - if test x"${lincdir}" = x -o x"${llibdir}" = x; then - for i in \ - `ls -d ${exec_prefix}/lib 2>/dev/null`\ - `ls -d ${prefix}/lib 2>/dev/null`\ - `ls -d /usr/local/lib 2>/dev/null`\ - `ls -d /usr/lib 2>/dev/null`\ - `ls -d /usr/lib/x86_64-linux-gnu 2>/dev/null` ; do - if test x"`ls $i/liblmdb* 2>/dev/null`" != x ; then - llibdir=`(cd $i; pwd)` - break - fi - done - for i in \ - `ls -d ${prefix}/include 2>/dev/null`\ - `ls -d /usr/local/include 2>/dev/null`\ - `ls -d /usr/include 2>/dev/null` ; do - if test -f "$i/lmdb.h" ; then - lincdir=`(cd $i; pwd)` - break - fi - done - if test x"$llibdir" = x -o x"$lincdir" = x ; then - AC_MSG_ERROR([none found]) - else - AC_MSG_RESULT([found in $llibdir, includes in $lincdir]) - AC_DEFINE(HAVE_LMDB) - LMDB_CFLAGS="-I\"$lincdir\"" - LMDB_LIBS="-L\"$llibdir\" -llmdb" - fi - fi + AC_MSG_CHECKING([for LMDB library]) + AC_CACHE_VAL(ac_cv_c_lmdb,[ + if test x"${with_lmdb}" != x -a "${with_lmdb}" != "yes"; then + if test -f "${with_lmdb}/lmdb.h" -a x"`ls ${with_lmdb}/liblmdb* 2>/dev/null`" != x; then + ac_cv_c_lmdb=`(cd ${with_lmdb}; pwd)` + lincdir=$ac_cv_c_lmdb + llibdir=$ac_cv_c_lmdb + AC_MSG_RESULT([found in $llibdir]) + else + AC_MSG_ERROR([${with_lmdb} directory doesn't contain lmdb library]) + fi + fi + ]) + if test x"${lincdir}" = x -o x"${llibdir}" = x; then + for i in \ + `ls -d ${exec_prefix}/lib 2>/dev/null`\ + `ls -d ${prefix}/lib 2>/dev/null`\ + `ls -d /usr/local/lib 2>/dev/null`\ + `ls -d /usr/lib 2>/dev/null`\ + `ls -d /usr/lib/x86_64-linux-gnu 2>/dev/null` ; do + if test x"`ls $i/liblmdb* 2>/dev/null`" != x ; then + llibdir=`(cd $i; pwd)` + break + fi + done + for i in \ + `ls -d ${prefix}/include 2>/dev/null`\ + `ls -d /usr/local/include 2>/dev/null`\ + `ls -d /usr/include 2>/dev/null` ; do + if test -f "$i/lmdb.h" ; then + lincdir=`(cd $i; pwd)` + break + fi + done + if test x"$llibdir" = x -o x"$lincdir" = x ; then + AC_MSG_ERROR([none found]) + else + AC_MSG_RESULT([found in $llibdir, includes in $lincdir]) + AC_DEFINE(HAVE_LMDB) + LMDB_CFLAGS="-I\"$lincdir\"" + LMDB_LIBS="-L\"$llibdir\" -llmdb" + fi + fi fi ]) diff --git a/configure b/configure index 30bb5ae..0418d83 100755 --- a/configure +++ b/configure @@ -3870,11 +3870,11 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu printf %s "checking for existence of ${TCL_BIN_DIR}/tclConfig.sh... " >&6; } if test -f "${TCL_BIN_DIR}/tclConfig.sh" ; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: loading" >&5 + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: loading" >&5 printf "%s\n" "loading" >&6; } . "${TCL_BIN_DIR}/tclConfig.sh" else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: could not find ${TCL_BIN_DIR}/tclConfig.sh" >&5 + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: could not find ${TCL_BIN_DIR}/tclConfig.sh" >&5 printf "%s\n" "could not find ${TCL_BIN_DIR}/tclConfig.sh" >&6; } fi @@ -3885,9 +3885,9 @@ printf "%s\n" "could not find ${TCL_BIN_DIR}/tclConfig.sh" >&6; } # instead of TCL_BUILD_LIB_SPEC since it will work with both an # installed and uninstalled version of Tcl. if test -f "${TCL_BIN_DIR}/Makefile" ; then - TCL_LIB_SPEC="${TCL_BUILD_LIB_SPEC}" - TCL_STUB_LIB_SPEC="${TCL_BUILD_STUB_LIB_SPEC}" - TCL_STUB_LIB_PATH="${TCL_BUILD_STUB_LIB_PATH}" + TCL_LIB_SPEC="${TCL_BUILD_LIB_SPEC}" + TCL_STUB_LIB_SPEC="${TCL_BUILD_STUB_LIB_SPEC}" + TCL_STUB_LIB_PATH="${TCL_BUILD_STUB_LIB_PATH}" elif test "`uname -s`" = "Darwin"; then # If Tcl was built as a framework, attempt to use the libraries # from the framework at the given location so that linking works @@ -5481,51 +5481,51 @@ then : else case e in #( e) if test x"${with_gdbm}" != x -a "${with_gdbm}" != "yes"; then - if test -f "${with_gdbm}/gdbm.h" -a x"`ls ${with_gdbm}/libgdbm* 2>/dev/null`" != x; then - ac_cv_c_gdbm=`(cd ${with_gdbm}; pwd)` - gincdir=$ac_cv_c_gdbm - glibdir=$ac_cv_c_gdbm - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found in $glibdir" >&5 + if test -f "${with_gdbm}/gdbm.h" -a x"`ls ${with_gdbm}/libgdbm* 2>/dev/null`" != x; then + ac_cv_c_gdbm=`(cd ${with_gdbm}; pwd)` + gincdir=$ac_cv_c_gdbm + glibdir=$ac_cv_c_gdbm + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found in $glibdir" >&5 printf "%s\n" "found in $glibdir" >&6; } - else - as_fn_error $? "${with_gdbm} directory doesn't contain gdbm library" "$LINENO" 5 - fi + else + as_fn_error $? "${with_gdbm} directory doesn't contain gdbm library" "$LINENO" 5 + fi fi ;; esac fi if test x"${gincdir}" = x -o x"${glibdir}" = x; then - for i in \ - `ls -d ${exec_prefix}/lib 2>/dev/null`\ - `ls -d ${prefix}/lib 2>/dev/null`\ - `ls -d /usr/local/lib 2>/dev/null`\ - `ls -d /usr/lib 2>/dev/null`\ - `ls -d /usr/lib/x86_64-linux-gnu 2>/dev/null` ; do - if test x"`ls $i/libgdbm* 2>/dev/null`" != x ; then - glibdir=`(cd $i; pwd)` - break - fi - done - for i in \ - `ls -d ${prefix}/include 2>/dev/null`\ - `ls -d /usr/local/include 2>/dev/null`\ - `ls -d /usr/include 2>/dev/null` ; do - if test -f "$i/gdbm.h" ; then - gincdir=`(cd $i; pwd)` - break - fi - done - if test x"$glibdir" = x -o x"$gincdir" = x ; then - as_fn_error $? "none found" "$LINENO" 5 - else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found in $glibdir, includes in $gincdir" >&5 + for i in \ + `ls -d ${exec_prefix}/lib 2>/dev/null`\ + `ls -d ${prefix}/lib 2>/dev/null`\ + `ls -d /usr/local/lib 2>/dev/null`\ + `ls -d /usr/lib 2>/dev/null`\ + `ls -d /usr/lib/x86_64-linux-gnu 2>/dev/null` ; do + if test x"`ls $i/libgdbm* 2>/dev/null`" != x ; then + glibdir=`(cd $i; pwd)` + break + fi + done + for i in \ + `ls -d ${prefix}/include 2>/dev/null`\ + `ls -d /usr/local/include 2>/dev/null`\ + `ls -d /usr/include 2>/dev/null` ; do + if test -f "$i/gdbm.h" ; then + gincdir=`(cd $i; pwd)` + break + fi + done + if test x"$glibdir" = x -o x"$gincdir" = x ; then + as_fn_error $? "none found" "$LINENO" 5 + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found in $glibdir, includes in $gincdir" >&5 printf "%s\n" "found in $glibdir, includes in $gincdir" >&6; } - printf "%s\n" "#define HAVE_GDBM 1" >>confdefs.h + printf "%s\n" "#define HAVE_GDBM 1" >>confdefs.h - GDBM_CFLAGS="-I\"$gincdir\"" - GDBM_LIBS="-L\"$glibdir\" -lgdbm" - fi + GDBM_CFLAGS="-I\"$gincdir\"" + GDBM_LIBS="-L\"$glibdir\" -lgdbm" + fi fi fi @@ -5545,60 +5545,60 @@ fi if test x"${with_lmdb}" != "x" -a "${with_lmdb}" != no; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for LMDB library" >&5 + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for LMDB library" >&5 printf %s "checking for LMDB library... " >&6; } - if test ${ac_cv_c_lmdb+y} + if test ${ac_cv_c_lmdb+y} then : printf %s "(cached) " >&6 else case e in #( e) - if test x"${with_lmdb}" != x -a "${with_lmdb}" != "yes"; then - if test -f "${with_lmdb}/lmdb.h" -a x"`ls ${with_lmdb}/liblmdb* 2>/dev/null`" != x; then - ac_cv_c_lmdb=`(cd ${with_lmdb}; pwd)` - lincdir=$ac_cv_c_lmdb - llibdir=$ac_cv_c_lmdb - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found in $llibdir" >&5 + if test x"${with_lmdb}" != x -a "${with_lmdb}" != "yes"; then + if test -f "${with_lmdb}/lmdb.h" -a x"`ls ${with_lmdb}/liblmdb* 2>/dev/null`" != x; then + ac_cv_c_lmdb=`(cd ${with_lmdb}; pwd)` + lincdir=$ac_cv_c_lmdb + llibdir=$ac_cv_c_lmdb + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found in $llibdir" >&5 printf "%s\n" "found in $llibdir" >&6; } - else - as_fn_error $? "${with_lmdb} directory doesn't contain lmdb library" "$LINENO" 5 - fi - fi - ;; -esac -fi - - if test x"${lincdir}" = x -o x"${llibdir}" = x; then - for i in \ - `ls -d ${exec_prefix}/lib 2>/dev/null`\ - `ls -d ${prefix}/lib 2>/dev/null`\ - `ls -d /usr/local/lib 2>/dev/null`\ - `ls -d /usr/lib 2>/dev/null`\ - `ls -d /usr/lib/x86_64-linux-gnu 2>/dev/null` ; do - if test x"`ls $i/liblmdb* 2>/dev/null`" != x ; then - llibdir=`(cd $i; pwd)` - break - fi - done - for i in \ - `ls -d ${prefix}/include 2>/dev/null`\ - `ls -d /usr/local/include 2>/dev/null`\ - `ls -d /usr/include 2>/dev/null` ; do - if test -f "$i/lmdb.h" ; then - lincdir=`(cd $i; pwd)` - break - fi - done - if test x"$llibdir" = x -o x"$lincdir" = x ; then - as_fn_error $? "none found" "$LINENO" 5 - else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found in $llibdir, includes in $lincdir" >&5 + else + as_fn_error $? "${with_lmdb} directory doesn't contain lmdb library" "$LINENO" 5 + fi + fi + ;; +esac +fi + + if test x"${lincdir}" = x -o x"${llibdir}" = x; then + for i in \ + `ls -d ${exec_prefix}/lib 2>/dev/null`\ + `ls -d ${prefix}/lib 2>/dev/null`\ + `ls -d /usr/local/lib 2>/dev/null`\ + `ls -d /usr/lib 2>/dev/null`\ + `ls -d /usr/lib/x86_64-linux-gnu 2>/dev/null` ; do + if test x"`ls $i/liblmdb* 2>/dev/null`" != x ; then + llibdir=`(cd $i; pwd)` + break + fi + done + for i in \ + `ls -d ${prefix}/include 2>/dev/null`\ + `ls -d /usr/local/include 2>/dev/null`\ + `ls -d /usr/include 2>/dev/null` ; do + if test -f "$i/lmdb.h" ; then + lincdir=`(cd $i; pwd)` + break + fi + done + if test x"$llibdir" = x -o x"$lincdir" = x ; then + as_fn_error $? "none found" "$LINENO" 5 + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found in $llibdir, includes in $lincdir" >&5 printf "%s\n" "found in $llibdir, includes in $lincdir" >&6; } - printf "%s\n" "#define HAVE_LMDB 1" >>confdefs.h + printf "%s\n" "#define HAVE_LMDB 1" >>confdefs.h - LMDB_CFLAGS="-I\"$lincdir\"" - LMDB_LIBS="-L\"$llibdir\" -llmdb" - fi - fi + LMDB_CFLAGS="-I\"$lincdir\"" + LMDB_LIBS="-L\"$llibdir\" -llmdb" + fi + fi fi @@ -5625,31 +5625,31 @@ then : else case e in #( e) if test x"${with_naviserver}" != x ; then - if test -f "${with_naviserver}/include/ns.h" ; then - ac_cv_c_naviserver=`(cd ${with_naviserver}; pwd)` - else - as_fn_error $? "${with_naviserver} directory doesn't contain ns.h" "$LINENO" 5 - fi + if test -f "${with_naviserver}/include/ns.h" ; then + ac_cv_c_naviserver=`(cd ${with_naviserver}; pwd)` + else + as_fn_error $? "${with_naviserver} directory doesn't contain ns.h" "$LINENO" 5 + fi fi ;; esac fi if test x"${ac_cv_c_naviserver}" = x ; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none found" >&5 + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none found" >&5 printf "%s\n" "none found" >&6; } else - NS_DIR=${ac_cv_c_naviserver} - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found NaviServer/AOLserver in $NS_DIR" >&5 + NS_DIR=${ac_cv_c_naviserver} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found NaviServer/AOLserver in $NS_DIR" >&5 printf "%s\n" "found NaviServer/AOLserver in $NS_DIR" >&6; } - NS_INCLUDES="-I\"${NS_DIR}/include\"" - if test "`uname -s`" = Darwin ; then - aollibs=`ls ${NS_DIR}/lib/libns* 2>/dev/null` - if test x"$aollibs" != x ; then - NS_LIBS="-L\"${NS_DIR}/lib\" -lnsd -lnsthread" - fi - fi - printf "%s\n" "#define NS_AOLSERVER 1" >>confdefs.h + NS_INCLUDES="-I\"${NS_DIR}/include\"" + if test "`uname -s`" = Darwin ; then + aollibs=`ls ${NS_DIR}/lib/libns* 2>/dev/null` + if test x"$aollibs" != x ; then + NS_LIBS="-L\"${NS_DIR}/lib\" -lnsd -lnsthread" + fi + fi + printf "%s\n" "#define NS_AOLSERVER 1" >>confdefs.h fi @@ -5666,15 +5666,15 @@ printf "%s\n" "found NaviServer/AOLserver in $NS_DIR" >&6; } vars="generic/threadNs.c \ - generic/threadCmd.c \ - generic/threadSvCmd.c \ - generic/threadSpCmd.c \ - generic/threadPoolCmd.c \ - generic/psGdbm.c \ - generic/psLmdb.c \ - generic/threadSvListCmd.c \ - generic/threadSvKeylistCmd.c \ - generic/tclXkeylist.c \ + generic/threadCmd.c \ + generic/threadSvCmd.c \ + generic/threadSpCmd.c \ + generic/threadPoolCmd.c \ + generic/psGdbm.c \ + generic/psLmdb.c \ + generic/threadSvListCmd.c \ + generic/threadSvKeylistCmd.c \ + generic/tclXkeylist.c \ " for i in $vars; do case $i in @@ -6350,7 +6350,7 @@ fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: shared" >&5 printf "%s\n" "shared" >&6; } SHARED_BUILD=1 - STUBS_BUILD=1 + STUBS_BUILD=1 else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: static" >&5 printf "%s\n" "static" >&6; } @@ -6358,11 +6358,11 @@ printf "%s\n" "static" >&6; } printf "%s\n" "#define STATIC_BUILD 1" >>confdefs.h - if test "$stubs_ok" = "yes" ; then - STUBS_BUILD=1 - else - STUBS_BUILD=0 - fi + if test "$stubs_ok" = "yes" ; then + STUBS_BUILD=1 + else + STUBS_BUILD=0 + fi fi if test "${STUBS_BUILD}" = "1" ; then @@ -6801,14 +6801,14 @@ fi fi if test "$GCC" != "yes" ; then - if test "${SHARED_BUILD}" = "0" ; then + if test "${SHARED_BUILD}" = "0" ; then runtime=-MT - else + else runtime=-MD - fi - case "x`echo \${VisualStudioVersion}`" in - x1[4-9]*) - lflags="${lflags} -nodefaultlib:libucrt.lib" + fi + case "x`echo \${VisualStudioVersion}`" in + x1[4-9]*) + lflags="${lflags} -nodefaultlib:libucrt.lib" vars="ucrt.lib" for i in $vars; do @@ -6820,12 +6820,12 @@ fi done - ;; - *) - ;; - esac + ;; + *) + ;; + esac - if test "$do64bit" != "no" ; then + if test "$do64bit" != "no" ; then CC="cl.exe" RC="rc.exe" lflags="${lflags} -nologo -MACHINE:${MACHINE} " @@ -7542,19 +7542,19 @@ fi if test "$do64bit" = yes then : - if test "$GCC" = yes + if test "$GCC" = yes then : - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported by gcc" >&5 + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported by gcc" >&5 printf "%s\n" "$as_me: WARNING: 64bit mode not supported by gcc" >&2;} else case e in #( e) - do64bit_ok=yes - SHLIB_LD="ld -64 -shared -rdata_shared" - CFLAGS="$CFLAGS -64" - LDFLAGS_ARCH="-64" - ;; + do64bit_ok=yes + SHLIB_LD="ld -64 -shared -rdata_shared" + CFLAGS="$CFLAGS -64" + LDFLAGS_ARCH="-64" + ;; esac fi @@ -7582,7 +7582,7 @@ then : LDFLAGS="$LDFLAGS $PTHREAD_LIBS" fi ;; - esac + esac if test $doRpath = yes then : @@ -8046,11 +8046,11 @@ printf "%s\n" "#define _OE_SOCKETS 1" >>confdefs.h if test "$SHARED_BUILD" = 1 then : - SHLIB_LD='ld -shared -expect_unresolved "*"' + SHLIB_LD='ld -shared -expect_unresolved "*"' else case e in #( e) - SHLIB_LD='ld -non_shared -expect_unresolved "*"' + SHLIB_LD='ld -non_shared -expect_unresolved "*"' ;; esac fi @@ -8339,7 +8339,7 @@ esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext - LDFLAGS=$hold_ldflags ;; + LDFLAGS=$hold_ldflags ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_Bexport" >&5 @@ -8782,15 +8782,15 @@ rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext # See if we could use long anyway Note that we substitute in the # type that is our current guess for a 64-bit type inside this check # program, so it should be modified only carefully... - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { switch (0) { - case 1: case (sizeof(${tcl_type_64bit})==sizeof(long)): ; - } + case 1: case (sizeof(${tcl_type_64bit})==sizeof(long)): ; + } ; return 0; } @@ -8948,7 +8948,7 @@ int main (void) { struct dirent64 *p; DIR64 d = opendir64("."); - p = readdir64(d); rewinddir64(d); closedir64(d); + p = readdir64(d); rewinddir64(d); closedir64(d); ; return 0; } @@ -9052,8 +9052,8 @@ esac fi if test "x${tcl_cv_type_off64_t}" = "xyes" && \ - test "x${ac_cv_func_lseek64}" = "xyes" && \ - test "x${ac_cv_func_open64}" = "xyes" ; then + test "x${ac_cv_func_lseek64}" = "xyes" && \ + test "x${ac_cv_func_open64}" = "xyes" ; then printf "%s\n" "#define HAVE_TYPE_OFF64_T 1" >>confdefs.h @@ -9416,37 +9416,37 @@ printf "%s\n" "#define TCL_MAJOR_VERSION 8" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for tclsh" >&5 printf %s "checking for tclsh... " >&6; } if test -f "${TCL_BIN_DIR}/Makefile" ; then - # tclConfig.sh is in Tcl build directory - if test "${TEA_PLATFORM}" = "windows"; then - if test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${EXEEXT}" ; then - TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${EXEEXT}" - elif test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}s${EXEEXT}" ; then - TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}s${EXEEXT}" - elif test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}t${EXEEXT}" ; then - TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}t${EXEEXT}" - elif test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}st${EXEEXT}" ; then - TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}st${EXEEXT}" - fi - else - TCLSH_PROG="${TCL_BIN_DIR}/tclsh" - fi + # tclConfig.sh is in Tcl build directory + if test "${TEA_PLATFORM}" = "windows"; then + if test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${EXEEXT}" ; then + TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${EXEEXT}" + elif test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}s${EXEEXT}" ; then + TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}s${EXEEXT}" + elif test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}t${EXEEXT}" ; then + TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}t${EXEEXT}" + elif test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}st${EXEEXT}" ; then + TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}st${EXEEXT}" + fi + else + TCLSH_PROG="${TCL_BIN_DIR}/tclsh" + fi else - # tclConfig.sh is in install location - if test "${TEA_PLATFORM}" = "windows"; then - TCLSH_PROG="tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${EXEEXT}" - else - TCLSH_PROG="tclsh${TCL_MAJOR_VERSION}.${TCL_MINOR_VERSION}" - fi - list="`ls -d ${TCL_BIN_DIR}/../bin 2>/dev/null` \ - `ls -d ${TCL_BIN_DIR}/.. 2>/dev/null` \ - `ls -d ${TCL_PREFIX}/bin 2>/dev/null`" - for i in $list ; do - if test -f "$i/${TCLSH_PROG}" ; then - REAL_TCL_BIN_DIR="`cd "$i"; pwd`/" - break - fi - done - TCLSH_PROG="${REAL_TCL_BIN_DIR}${TCLSH_PROG}" + # tclConfig.sh is in install location + if test "${TEA_PLATFORM}" = "windows"; then + TCLSH_PROG="tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${EXEEXT}" + else + TCLSH_PROG="tclsh${TCL_MAJOR_VERSION}.${TCL_MINOR_VERSION}" + fi + list="`ls -d ${TCL_BIN_DIR}/../bin 2>/dev/null` \ + `ls -d ${TCL_BIN_DIR}/.. 2>/dev/null` \ + `ls -d ${TCL_PREFIX}/bin 2>/dev/null`" + for i in $list ; do + if test -f "$i/${TCLSH_PROG}" ; then + REAL_TCL_BIN_DIR="`cd "$i"; pwd`/" + break + fi + done + TCLSH_PROG="${REAL_TCL_BIN_DIR}${TCLSH_PROG}" fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ${TCLSH_PROG}" >&5 printf "%s\n" "${TCLSH_PROG}" >&6; } @@ -9486,25 +9486,25 @@ else case e in #( e) search_path=`echo ${PATH} | sed -e 's/:/ /g'` for dir in $search_path ; do - for j in `ls -r $dir/macher 2> /dev/null` \ - `ls -r $dir/macher 2> /dev/null` ; do - if test x"$ac_cv_path_macher" = x ; then - if test -f "$j" ; then - ac_cv_path_macher=$j - break - fi - fi - done + for j in `ls -r $dir/macher 2> /dev/null` \ + `ls -r $dir/macher 2> /dev/null` ; do + if test x"$ac_cv_path_macher" = x ; then + if test -f "$j" ; then + ac_cv_path_macher=$j + break + fi + fi + done done ;; esac fi if test -f "$ac_cv_path_macher" ; then - MACHER_PROG="$ac_cv_path_macher" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $MACHER_PROG" >&5 + MACHER_PROG="$ac_cv_path_macher" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $MACHER_PROG" >&5 printf "%s\n" "$MACHER_PROG" >&6; } - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Found macher in environment" >&5 + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Found macher in environment" >&5 printf "%s\n" "Found macher in environment" >&6; } fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for zip" >&5 @@ -9516,37 +9516,37 @@ else case e in #( e) search_path=`echo ${PATH} | sed -e 's/:/ /g'` for dir in $search_path ; do - for j in `ls -r $dir/zip 2> /dev/null` \ - `ls -r $dir/zip 2> /dev/null` ; do - if test x"$ac_cv_path_zip" = x ; then - if test -f "$j" ; then - ac_cv_path_zip=$j - break - fi - fi - done + for j in `ls -r $dir/zip 2> /dev/null` \ + `ls -r $dir/zip 2> /dev/null` ; do + if test x"$ac_cv_path_zip" = x ; then + if test -f "$j" ; then + ac_cv_path_zip=$j + break + fi + fi + done done ;; esac fi if test -f "$ac_cv_path_zip" ; then - ZIP_PROG="$ac_cv_path_zip" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ZIP_PROG" >&5 + ZIP_PROG="$ac_cv_path_zip" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ZIP_PROG" >&5 printf "%s\n" "$ZIP_PROG" >&6; } - ZIP_PROG_OPTIONS="-rq" - ZIP_PROG_VFSSEARCH="*" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Found INFO Zip in environment" >&5 + ZIP_PROG_OPTIONS="-rq" + ZIP_PROG_VFSSEARCH="*" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Found INFO Zip in environment" >&5 printf "%s\n" "Found INFO Zip in environment" >&6; } - # Use standard arguments for zip + # Use standard arguments for zip else - # It is not an error if an installed version of Zip can't be located. - # We can use the locally distributed minizip instead - ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}" - ZIP_PROG_OPTIONS="-o -r" - ZIP_PROG_VFSSEARCH="*" - ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: No zip found on PATH. Building minizip" >&5 + # It is not an error if an installed version of Zip can't be located. + # We can use the locally distributed minizip instead + ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}" + ZIP_PROG_OPTIONS="-o -r" + ZIP_PROG_VFSSEARCH="*" + ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: No zip found on PATH. Building minizip" >&5 printf "%s\n" "No zip found on PATH. Building minizip" >&6; } fi diff --git a/configure.ac b/configure.ac index e2c4727..6cdad7f 100644 --- a/configure.ac +++ b/configure.ac @@ -100,15 +100,15 @@ NS_PATH_AOLSERVER #----------------------------------------------------------------------- TEA_ADD_SOURCES([generic/threadNs.c \ - generic/threadCmd.c \ - generic/threadSvCmd.c \ - generic/threadSpCmd.c \ - generic/threadPoolCmd.c \ - generic/psGdbm.c \ - generic/psLmdb.c \ - generic/threadSvListCmd.c \ - generic/threadSvKeylistCmd.c \ - generic/tclXkeylist.c \ + generic/threadCmd.c \ + generic/threadSvCmd.c \ + generic/threadSpCmd.c \ + generic/threadPoolCmd.c \ + generic/psGdbm.c \ + generic/psLmdb.c \ + generic/threadSvListCmd.c \ + generic/threadSvKeylistCmd.c \ + generic/tclXkeylist.c \ ]) TEA_ADD_HEADERS([generic/tclThread.h]) diff --git a/doc/format.tcl b/doc/format.tcl index 394c462..ffff9a6 100644 --- a/doc/format.tcl +++ b/doc/format.tcl @@ -11,20 +11,20 @@ set code [catch { set m [read $f] close $f foreach file [glob -nocomplain *.man] { - set xx [file root $file] - set f [open $xx.man] - set t [read $f] - close $f - foreach {fmt ext dir} {nroff n man html html htm} { - dt configure -format $fmt - set o [dt format $t] - set f [open $dir/$xx.$ext w] - if {$fmt == "nroff"} { - set o [string map [list {.so man.macros} $m] $o] - } - puts $f $o - close $f - } + set xx [file root $file] + set f [open $xx.man] + set t [read $f] + close $f + foreach {fmt ext dir} {nroff n man html html htm} { + dt configure -format $fmt + set o [dt format $t] + set f [open $dir/$xx.$ext w] + if {$fmt == "nroff"} { + set o [string map [list {.so man.macros} $m] $o] + } + puts $f $o + close $f + } } } err] file rename htm html diff --git a/generic/psGdbm.c b/generic/psGdbm.c index 4a52a09..c200ecb 100644 --- a/generic/psGdbm.c +++ b/generic/psGdbm.c @@ -154,7 +154,7 @@ ps_gdbm_get( drec = gdbm_fetch(dbf, dkey); if (drec.dptr == NULL) { - return 1; + return 1; } *dataptrptr = drec.dptr; @@ -191,11 +191,11 @@ ps_gdbm_first( dkey = gdbm_firstkey(dbf); if (dkey.dptr == NULL) { - return 1; + return 1; } drec = gdbm_fetch(dbf, dkey); if (drec.dptr == NULL) { - return 1; + return 1; } *dataptrptr = drec.dptr; @@ -237,11 +237,11 @@ static int ps_gdbm_next( free(*keyptrptr), *keyptrptr = NULL; if (dnext.dptr == NULL) { - return 1; + return 1; } drec = gdbm_fetch(dbf, dnext); if (drec.dptr == NULL) { - return 1; + return 1; } *dataptrptr = drec.dptr; @@ -287,7 +287,7 @@ ps_gdbm_put( ret = gdbm_store(dbf, dkey, drec, GDBM_REPLACE); if (ret == -1) { - return -1; + return -1; } return 0; @@ -324,7 +324,7 @@ ps_gdbm_delete( ret = gdbm_delete(dbf, dkey); if (ret == -1) { - return -1; + return -1; } return 0; diff --git a/generic/psLmdb.c b/generic/psLmdb.c index fc811d5..34aa417 100644 --- a/generic/psLmdb.c +++ b/generic/psLmdb.c @@ -42,26 +42,26 @@ void LmdbTxnGet(LmdbCtx ctx, enum LmdbOpenMode mode) // Read transactions are reused, if possible if (ctx->txn && mode == LmdbRead) { - ctx->err = mdb_txn_renew(ctx->txn); - if (ctx->err) - { - ctx->txn = NULL; - } + ctx->err = mdb_txn_renew(ctx->txn); + if (ctx->err) + { + ctx->txn = NULL; + } } else if (ctx->txn && mode == LmdbWrite) { - LmdbTxnAbort(ctx); + LmdbTxnAbort(ctx); } if (ctx->txn == NULL) { - ctx->err = mdb_txn_begin(ctx->env, NULL, 0, &ctx->txn); + ctx->err = mdb_txn_begin(ctx->env, NULL, 0, &ctx->txn); } if (ctx->err) { - ctx->txn = NULL; - return; + ctx->txn = NULL; + return; } // Given the setup above, and the arguments given, this won't fail. @@ -162,7 +162,7 @@ ps_lmdb_open( ctx = (LmdbCtx)ckalloc(sizeof(*ctx)); if (ctx == NULL) { - return NULL; + return NULL; } ctx->env = NULL; @@ -173,8 +173,8 @@ ps_lmdb_open( ctx->err = mdb_env_create(&ctx->env); if (ctx->err) { - ckfree(ctx); - return NULL; + ckfree(ctx); + return NULL; } Tcl_DStringInit(&toext); @@ -184,8 +184,8 @@ ps_lmdb_open( if (ctx->err) { - ckfree(ctx); - return NULL; + ckfree(ctx); + return NULL; } return ctx; @@ -213,11 +213,11 @@ ps_lmdb_close( LmdbCtx ctx = (LmdbCtx)handle; if (ctx->cur) { - mdb_cursor_close(ctx->cur); + mdb_cursor_close(ctx->cur); } if (ctx->txn) { - LmdbTxnAbort(ctx); + LmdbTxnAbort(ctx); } mdb_env_close(ctx->env); @@ -255,7 +255,7 @@ ps_lmdb_get( LmdbTxnGet(ctx, LmdbRead); if (ctx->err) { - return 1; + return 1; } key.mv_data = (void *)keyptr; @@ -264,8 +264,8 @@ ps_lmdb_get( ctx->err = mdb_get(ctx->txn, ctx->dbi, &key, &data); if (ctx->err) { - mdb_txn_reset(ctx->txn); - return 1; + mdb_txn_reset(ctx->txn); + return 1; } *dataptrptr = (char *)data.mv_data; @@ -310,22 +310,22 @@ ps_lmdb_first( LmdbTxnGet(ctx, LmdbRead); if (ctx->err) { - return 1; + return 1; } ctx->err = mdb_cursor_open(ctx->txn, ctx->dbi, &ctx->cur); if (ctx->err) { - return 1; + return 1; } ctx->err = mdb_cursor_get(ctx->cur, &key, &data, MDB_FIRST); if (ctx->err) { - mdb_txn_reset(ctx->txn); - mdb_cursor_close(ctx->cur); - ctx->cur = NULL; - return 1; + mdb_txn_reset(ctx->txn); + mdb_cursor_close(ctx->cur); + ctx->cur = NULL; + return 1; } *dataptrptr = (char *)data.mv_data; @@ -363,10 +363,10 @@ static int ps_lmdb_next( ctx->err = mdb_cursor_get(ctx->cur, &key, &data, MDB_NEXT); if (ctx->err) { - mdb_txn_reset(ctx->txn); - mdb_cursor_close(ctx->cur); - ctx->cur = NULL; - return 1; + mdb_txn_reset(ctx->txn); + mdb_cursor_close(ctx->cur); + ctx->cur = NULL; + return 1; } *dataptrptr = (char *)data.mv_data; @@ -406,7 +406,7 @@ ps_lmdb_put( LmdbTxnGet(ctx, LmdbWrite); if (ctx->err) { - return -1; + return -1; } key.mv_data = (void*)keyptr; @@ -418,11 +418,11 @@ ps_lmdb_put( ctx->err = mdb_put(ctx->txn, ctx->dbi, &key, &data, 0); if (ctx->err) { - LmdbTxnAbort(ctx); + LmdbTxnAbort(ctx); } else { - LmdbTxnCommit(ctx); + LmdbTxnCommit(ctx); } return ctx->err ? -1 : 0; @@ -456,7 +456,7 @@ ps_lmdb_delete( LmdbTxnGet(ctx, LmdbWrite); if (ctx->err) { - return -1; + return -1; } key.mv_data = (void*)keyptr; @@ -465,11 +465,11 @@ ps_lmdb_delete( ctx->err = mdb_del(ctx->txn, ctx->dbi, &key, NULL); if (ctx->err) { - LmdbTxnAbort(ctx); + LmdbTxnAbort(ctx); } else { - LmdbTxnCommit(ctx); + LmdbTxnCommit(ctx); } ctx->txn = NULL; @@ -504,7 +504,7 @@ ps_lmdb_free( if (ctx->cur == NULL) { - mdb_txn_reset(ctx->txn); + mdb_txn_reset(ctx->txn); } } diff --git a/generic/tclThreadInt.h b/generic/tclThreadInt.h index 8bf808c..ead632c 100644 --- a/generic/tclThreadInt.h +++ b/generic/tclThreadInt.h @@ -116,16 +116,16 @@ MODULE_SCOPE const char *TpoolInit(Tcl_Interp *interp); #define SpliceIn(a,b) \ (a)->nextPtr = (b); \ if ((b) != NULL) \ - (b)->prevPtr = (a); \ + (b)->prevPtr = (a); \ (a)->prevPtr = NULL, (b) = (a) #define SpliceOut(a,b) \ if ((a)->prevPtr != NULL) \ - (a)->prevPtr->nextPtr = (a)->nextPtr; \ + (a)->prevPtr->nextPtr = (a)->nextPtr; \ else \ - (b) = (a)->nextPtr; \ + (b) = (a)->nextPtr; \ if ((a)->nextPtr != NULL) \ - (a)->nextPtr->prevPtr = (a)->prevPtr + (a)->nextPtr->prevPtr = (a)->prevPtr /* * Version macros diff --git a/generic/tclXkeylist.c b/generic/tclXkeylist.c index 705cf0c..396392b 100644 --- a/generic/tclXkeylist.c +++ b/generic/tclXkeylist.c @@ -43,8 +43,8 @@ #ifdef TCLX_DEBUG # define TclX_Assert(expr) ((expr) ? NULL : \ - panic("TclX assertion failure: %s:%d \"%s\"\n",\ - __FILE__, __LINE__, "expr")) + panic("TclX assertion failure: %s:%d \"%s\"\n",\ + __FILE__, __LINE__, "expr")) #else # define TclX_Assert(expr) #endif @@ -84,11 +84,11 @@ TclX_IsNullObj ( Tcl_Obj *objPtr ) { if (objPtr->typePtr == NULL) { - return (objPtr->length == 0); + return (objPtr->length == 0); } else if (objPtr->typePtr == listType) { - Tcl_Size length; - Tcl_ListObjLength(NULL, objPtr, &length); - return (length == 0); + Tcl_Size length; + Tcl_ListObjLength(NULL, objPtr, &length); + return (length == 0); } (void)Tcl_GetString(objPtr); return (objPtr->length == 0); @@ -117,16 +117,16 @@ TclX_AppendObjResult(Tcl_Interp *interp, ...) resultPtr = Tcl_GetObjResult (interp); if (Tcl_IsShared(resultPtr)) { - resultPtr = Tcl_NewStringObj(NULL, 0); - Tcl_SetObjResult(interp, resultPtr); + resultPtr = Tcl_NewStringObj(NULL, 0); + Tcl_SetObjResult(interp, resultPtr); } while (1) { - string = va_arg(argList, char *); - if (string == NULL) { - break; - } - Tcl_AppendToObj (resultPtr, string, -1); + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + Tcl_AppendToObj (resultPtr, string, -1); } va_end(argList); } @@ -154,12 +154,12 @@ TclX_WrongArgs( Tcl_ResetResult(interp); Tcl_AppendStringsToObj (resultPtr, - tclXWrongArgs, - commandName, - NULL); + tclXWrongArgs, + commandName, + NULL); if (*string != '\0') { - Tcl_AppendStringsToObj (resultPtr, " ", string, (void *)NULL); + Tcl_AppendStringsToObj (resultPtr, " ", string, (void *)NULL); } return TCL_ERROR; } @@ -207,9 +207,9 @@ typedef struct { */ #define DupSharedKeyListChild(keylIntPtr, idx) \ if (Tcl_IsShared (keylIntPtr->entries [idx].valuePtr)) { \ - keylIntPtr->entries [idx].valuePtr = \ - Tcl_DuplicateObj (keylIntPtr->entries [idx].valuePtr); \ - Tcl_IncrRefCount (keylIntPtr->entries [idx].valuePtr); \ + keylIntPtr->entries [idx].valuePtr = \ + Tcl_DuplicateObj (keylIntPtr->entries [idx].valuePtr); \ + Tcl_IncrRefCount (keylIntPtr->entries [idx].valuePtr); \ } /* @@ -217,11 +217,11 @@ typedef struct { */ #ifdef TCLX_DEBUG # define KEYL_OBJ_ASSERT(keylAPtr) {\ - TclX_Assert (keylAPtr->typePtr == &keyedListType.objType); \ - ValidateKeyedList (keylAIntPtr); \ + TclX_Assert (keylAPtr->typePtr == &keyedListType.objType); \ + ValidateKeyedList (keylAIntPtr); \ } # define KEYL_REP_ASSERT(keylAIntPtr) \ - ValidateKeyedList (keylAIntPtr) + ValidateKeyedList (keylAIntPtr) #else # define KEYL_REP_ASSERT(keylAIntPtr) #endif @@ -237,9 +237,9 @@ ValidateKeyedList(keylIntObj_t *keylIntPtr); static int ValidateKey(Tcl_Interp *interp, - const char *key, - size_t keyLen, - int isPath); + const char *key, + size_t keyLen, + int isPath); static keylIntObj_t * AllocKeyedListIntRep(void); @@ -249,60 +249,60 @@ FreeKeyedListData(keylIntObj_t *keylIntPtr); static void EnsureKeyedListSpace(keylIntObj_t *keylIntPtr, - int newNumEntries); + int newNumEntries); static void DeleteKeyedListEntry(keylIntObj_t *keylIntPtr, - int entryIdx); + int entryIdx); static int FindKeyedListEntry(keylIntObj_t *keylIntPtr, - const char *key, - size_t *keyLenPtr, - const char **nextSubKeyPtr); + const char *key, + size_t *keyLenPtr, + const char **nextSubKeyPtr); static int ObjToKeyedListEntry(Tcl_Interp *interp, - Tcl_Obj *objPtr, - keylEntry_t *entryPtr); + Tcl_Obj *objPtr, + keylEntry_t *entryPtr); static void DupKeyedListInternalRep(Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr); + Tcl_Obj *copyPtr); static void FreeKeyedListInternalRep(Tcl_Obj *keylPtr); static int SetKeyedListFromAny(Tcl_Interp *interp, - Tcl_Obj *objPtr); + Tcl_Obj *objPtr); static void UpdateStringOfKeyedList(Tcl_Obj *keylPtr); static int Tcl_KeylgetObjCmd(void *clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]); + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]); static int Tcl_KeylsetObjCmd(void *clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]); + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]); static int Tcl_KeyldelObjCmd(void *clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]); + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]); static int Tcl_KeylkeysObjCmd(void *clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]); + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]); /* * Type definition. */ @@ -334,17 +334,17 @@ ValidateKeyedList (keylIntPtr) TclX_Assert (keylIntPtr->arraySize >= 0); TclX_Assert (keylIntPtr->numEntries >= 0); TclX_Assert ((keylIntPtr->arraySize > 0) ? - (keylIntPtr->entries != NULL) : 1); + (keylIntPtr->entries != NULL) : 1); TclX_Assert ((keylIntPtr->numEntries > 0) ? - (keylIntPtr->entries != NULL) : 1); + (keylIntPtr->entries != NULL) : 1); for (idx = 0; idx < keylIntPtr->numEntries; idx++) { - keylEntry_t *entryPtr = &(keylIntPtr->entries [idx]); - TclX_Assert (entryPtr->key != NULL); - TclX_Assert (entryPtr->valuePtr->refCount >= 1); - if (entryPtr->valuePtr->typePtr == &keyedListType.objType) { - ValidateKeyedList (entryPtr->valuePtr->internalRep.twoPtrValue.ptr1); - } + keylEntry_t *entryPtr = &(keylIntPtr->entries [idx]); + TclX_Assert (entryPtr->key != NULL); + TclX_Assert (entryPtr->valuePtr->refCount >= 1); + if (entryPtr->valuePtr->typePtr == &keyedListType.objType) { + ValidateKeyedList (entryPtr->valuePtr->internalRep.twoPtrValue.ptr1); + } } } #endif @@ -373,28 +373,28 @@ ValidateKey( const char *keyp; if (strlen(key) != keyLen) { - Tcl_ResetResult(interp); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "keyed list key may not be a ", - "binary string", (char *) NULL); - return TCL_ERROR; + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "keyed list key may not be a ", + "binary string", (char *) NULL); + return TCL_ERROR; } if (key[0] == '\0') { - Tcl_ResetResult(interp); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "keyed list key may not be an ", - "empty string", (char *) NULL); - return TCL_ERROR; + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "keyed list key may not be an ", + "empty string", (char *) NULL); + return TCL_ERROR; } for (keyp = key; *keyp != '\0'; keyp++) { - if ((!isPath) && (*keyp == '.')) { - Tcl_ResetResult(interp); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "keyed list key may not contain a \".\"; ", - "it is used as a separator in key paths", - (char *) NULL); - return TCL_ERROR; - } + if ((!isPath) && (*keyp == '.')) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "keyed list key may not contain a \".\"; ", + "it is used as a separator in key paths", + (char *) NULL); + return TCL_ERROR; + } } return TCL_OK; } @@ -437,11 +437,11 @@ FreeKeyedListData( int idx; for (idx = 0; idx < keylIntPtr->numEntries ; idx++) { - ckfree (keylIntPtr->entries [idx].key); - Tcl_DecrRefCount (keylIntPtr->entries [idx].valuePtr); + ckfree (keylIntPtr->entries [idx].key); + Tcl_DecrRefCount (keylIntPtr->entries [idx].valuePtr); } if (keylIntPtr->entries != NULL) - ckfree ((char *) keylIntPtr->entries); + ckfree ((char *) keylIntPtr->entries); ckfree ((char *) keylIntPtr); } @@ -464,17 +464,17 @@ EnsureKeyedListSpace( KEYL_REP_ASSERT (keylIntPtr); if ((keylIntPtr->arraySize - keylIntPtr->numEntries) < newNumEntries) { - int newSize = keylIntPtr->arraySize + newNumEntries + - KEYEDLIST_ARRAY_INCR_SIZE; - if (keylIntPtr->entries == NULL) { - keylIntPtr->entries = (keylEntry_t *) - ckalloc (newSize * sizeof (keylEntry_t)); - } else { - keylIntPtr->entries = (keylEntry_t *) - ckrealloc ((void *) keylIntPtr->entries, - newSize * sizeof (keylEntry_t)); - } - keylIntPtr->arraySize = newSize; + int newSize = keylIntPtr->arraySize + newNumEntries + + KEYEDLIST_ARRAY_INCR_SIZE; + if (keylIntPtr->entries == NULL) { + keylIntPtr->entries = (keylEntry_t *) + ckalloc (newSize * sizeof (keylEntry_t)); + } else { + keylIntPtr->entries = (keylEntry_t *) + ckrealloc ((void *) keylIntPtr->entries, + newSize * sizeof (keylEntry_t)); + } + keylIntPtr->arraySize = newSize; } KEYL_REP_ASSERT (keylIntPtr); @@ -500,7 +500,7 @@ DeleteKeyedListEntry ( Tcl_DecrRefCount (keylIntPtr->entries [entryIdx].valuePtr); for (idx = entryIdx; idx < keylIntPtr->numEntries - 1; idx++) - keylIntPtr->entries [idx] = keylIntPtr->entries [idx + 1]; + keylIntPtr->entries [idx] = keylIntPtr->entries [idx + 1]; keylIntPtr->numEntries--; KEYL_REP_ASSERT (keylIntPtr); @@ -534,30 +534,30 @@ FindKeyedListEntry( keySeparPtr = strchr(key, '.'); if (keySeparPtr != NULL) { - keyLen = keySeparPtr - key; + keyLen = keySeparPtr - key; } else { - keyLen = strlen (key); + keyLen = strlen (key); } for (findIdx = 0; findIdx < keylIntPtr->numEntries; findIdx++) { - if ((strncmp (keylIntPtr->entries [findIdx].key, key, keyLen) == 0) && - (keylIntPtr->entries [findIdx].key [keyLen] == '\0')) - break; + if ((strncmp (keylIntPtr->entries [findIdx].key, key, keyLen) == 0) && + (keylIntPtr->entries [findIdx].key [keyLen] == '\0')) + break; } if (nextSubKeyPtr != NULL) { - if (keySeparPtr == NULL) { - *nextSubKeyPtr = NULL; - } else { - *nextSubKeyPtr = keySeparPtr + 1; - } + if (keySeparPtr == NULL) { + *nextSubKeyPtr = NULL; + } else { + *nextSubKeyPtr = keySeparPtr + 1; + } } if (keyLenPtr != NULL) { - *keyLenPtr = keyLen; + *keyLenPtr = keyLen; } if (findIdx >= keylIntPtr->numEntries) { - return -1; + return -1; } return findIdx; @@ -588,27 +588,27 @@ ObjToKeyedListEntry( const char *key; if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { - Tcl_ResetResult (interp); - Tcl_AppendStringsToObj(Tcl_GetObjResult (interp), - "keyed list entry not a valid list, ", - "found \"", - Tcl_GetString(objPtr), - "\"", (char *) NULL); - return TCL_ERROR; + Tcl_ResetResult (interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult (interp), + "keyed list entry not a valid list, ", + "found \"", + Tcl_GetString(objPtr), + "\"", (char *) NULL); + return TCL_ERROR; } if (objc != 2) { - Tcl_AppendStringsToObj(Tcl_GetObjResult (interp), - "keyed list entry must be a two ", - "element list, found \"", - Tcl_GetString(objPtr), - "\"", (char *) NULL); - return TCL_ERROR; + Tcl_AppendStringsToObj(Tcl_GetObjResult (interp), + "keyed list entry must be a two ", + "element list, found \"", + Tcl_GetString(objPtr), + "\"", (char *) NULL); + return TCL_ERROR; } key = Tcl_GetString(objv[0]); if (ValidateKey(interp, key, objv[0]->length, 0) == TCL_ERROR) { - return TCL_ERROR; + return TCL_ERROR; } entryPtr->key = ckstrdup(key); @@ -648,7 +648,7 @@ DupKeyedListInternalRep( Tcl_Obj *copyPtr ) { keylIntObj_t *srcIntPtr = (keylIntObj_t *) - srcPtr->internalRep.twoPtrValue.ptr1; + srcPtr->internalRep.twoPtrValue.ptr1; keylIntObj_t *copyIntPtr; int idx; @@ -658,13 +658,13 @@ DupKeyedListInternalRep( copyIntPtr->arraySize = srcIntPtr->arraySize; copyIntPtr->numEntries = srcIntPtr->numEntries; copyIntPtr->entries = (keylEntry_t *) - ckalloc (copyIntPtr->arraySize * sizeof (keylEntry_t)); + ckalloc (copyIntPtr->arraySize * sizeof (keylEntry_t)); for (idx = 0; idx < srcIntPtr->numEntries ; idx++) { - copyIntPtr->entries [idx].key = - ckstrdup (srcIntPtr->entries [idx].key); - copyIntPtr->entries [idx].valuePtr = srcIntPtr->entries [idx].valuePtr; - Tcl_IncrRefCount (copyIntPtr->entries [idx].valuePtr); + copyIntPtr->entries [idx].key = + ckstrdup (srcIntPtr->entries [idx].key); + copyIntPtr->entries [idx].valuePtr = srcIntPtr->entries [idx].valuePtr; + Tcl_IncrRefCount (copyIntPtr->entries [idx].valuePtr); } copyPtr->internalRep.twoPtrValue.ptr1 = copyIntPtr; @@ -690,7 +690,7 @@ DupKeyedListInternalRepShared ( Tcl_Obj *copyPtr ) { keylIntObj_t *srcIntPtr = (keylIntObj_t *) - srcPtr->internalRep.twoPtrValue.ptr1; + srcPtr->internalRep.twoPtrValue.ptr1; keylIntObj_t *copyIntPtr; int idx; @@ -700,14 +700,14 @@ DupKeyedListInternalRepShared ( copyIntPtr->arraySize = srcIntPtr->arraySize; copyIntPtr->numEntries = srcIntPtr->numEntries; copyIntPtr->entries = (keylEntry_t *) - ckalloc (copyIntPtr->arraySize * sizeof (keylEntry_t)); + ckalloc (copyIntPtr->arraySize * sizeof (keylEntry_t)); for (idx = 0; idx < srcIntPtr->numEntries ; idx++) { - copyIntPtr->entries [idx].key = - ckstrdup (srcIntPtr->entries [idx].key); - copyIntPtr->entries [idx].valuePtr = - Sv_DuplicateObj (srcIntPtr->entries [idx].valuePtr); - Tcl_IncrRefCount(copyIntPtr->entries [idx].valuePtr); + copyIntPtr->entries [idx].key = + ckstrdup (srcIntPtr->entries [idx].key); + copyIntPtr->entries [idx].valuePtr = + Sv_DuplicateObj (srcIntPtr->entries [idx].valuePtr); + Tcl_IncrRefCount(copyIntPtr->entries [idx].valuePtr); } copyPtr->internalRep.twoPtrValue.ptr1 = copyIntPtr; @@ -736,22 +736,22 @@ SetKeyedListFromAny( Tcl_Obj **objv; if (Tcl_ListObjGetElements (interp, objPtr, &objc, &objv) != TCL_OK) - return TCL_ERROR; + return TCL_ERROR; keylIntPtr = AllocKeyedListIntRep (); EnsureKeyedListSpace (keylIntPtr, objc); for (idx = 0; idx < objc; idx++) { - if (ObjToKeyedListEntry (interp, objv [idx], - &(keylIntPtr->entries [keylIntPtr->numEntries])) != TCL_OK) - goto errorExit; - keylIntPtr->numEntries++; + if (ObjToKeyedListEntry (interp, objv [idx], + &(keylIntPtr->entries [keylIntPtr->numEntries])) != TCL_OK) + goto errorExit; + keylIntPtr->numEntries++; } if ((objPtr->typePtr != NULL) && - (objPtr->typePtr->freeIntRepProc != NULL)) { - (*objPtr->typePtr->freeIntRepProc) (objPtr); + (objPtr->typePtr->freeIntRepProc != NULL)) { + (*objPtr->typePtr->freeIntRepProc) (objPtr); } objPtr->internalRep.twoPtrValue.ptr1 = keylIntPtr; objPtr->typePtr = &keyedListType.objType; @@ -782,16 +782,16 @@ UpdateStringOfKeyedList( Tcl_Obj *staticListObjv [UPDATE_STATIC_SIZE]; char *listStr; keylIntObj_t *keylIntPtr = (keylIntObj_t *) - keylPtr->internalRep.twoPtrValue.ptr1; + keylPtr->internalRep.twoPtrValue.ptr1; /* * Conversion to strings is done via list objects to support binary data. */ if (keylIntPtr->numEntries > UPDATE_STATIC_SIZE) { - listObjv = - (Tcl_Obj **) ckalloc (keylIntPtr->numEntries * sizeof (Tcl_Obj *)); + listObjv = + (Tcl_Obj **) ckalloc (keylIntPtr->numEntries * sizeof (Tcl_Obj *)); } else { - listObjv = staticListObjv; + listObjv = staticListObjv; } /* @@ -800,11 +800,11 @@ UpdateStringOfKeyedList( * FIX: Keeping key as string object will speed this up. */ for (idx = 0; idx < keylIntPtr->numEntries; idx++) { - entryObjv [0] = - Tcl_NewStringObj(keylIntPtr->entries [idx].key, - strlen (keylIntPtr->entries [idx].key)); - entryObjv [1] = keylIntPtr->entries [idx].valuePtr; - listObjv [idx] = Tcl_NewListObj (2, entryObjv); + entryObjv [0] = + Tcl_NewStringObj(keylIntPtr->entries [idx].key, + strlen (keylIntPtr->entries [idx].key)); + entryObjv [1] = keylIntPtr->entries [idx].valuePtr; + listObjv [idx] = Tcl_NewListObj (2, entryObjv); } tmpListObj = Tcl_NewListObj (keylIntPtr->numEntries, listObjv); @@ -814,7 +814,7 @@ UpdateStringOfKeyedList( Tcl_DecrRefCount (tmpListObj); if (listObjv != staticListObjv) - ckfree ((void*) listObjv); + ckfree ((void*) listObjv); } /*----------------------------------------------------------------------------- @@ -865,9 +865,9 @@ TclX_KeyedListGet( int findIdx; if (keylPtr->typePtr != &keyedListType.objType) { - if (SetKeyedListFromAny(interp, keylPtr) != TCL_OK) { - return TCL_ERROR; - } + if (SetKeyedListFromAny(interp, keylPtr) != TCL_OK) { + return TCL_ERROR; + } } keylIntPtr = (keylIntObj_t *)keylPtr->internalRep.twoPtrValue.ptr1; KEYL_REP_ASSERT (keylIntPtr); @@ -878,8 +878,8 @@ TclX_KeyedListGet( * If not found, return status. */ if (findIdx < 0) { - *valuePtrPtr = NULL; - return TCL_BREAK; + *valuePtrPtr = NULL; + return TCL_BREAK; } /* @@ -887,13 +887,13 @@ TclX_KeyedListGet( * down looking for the entry. */ if (nextSubKey == NULL) { - *valuePtrPtr = keylIntPtr->entries [findIdx].valuePtr; - return TCL_OK; + *valuePtrPtr = keylIntPtr->entries [findIdx].valuePtr; + return TCL_OK; } else { - return TclX_KeyedListGet (interp, - keylIntPtr->entries [findIdx].valuePtr, - nextSubKey, - valuePtrPtr); + return TclX_KeyedListGet (interp, + keylIntPtr->entries [findIdx].valuePtr, + nextSubKey, + valuePtrPtr); } } @@ -925,38 +925,38 @@ TclX_KeyedListSet( Tcl_Obj *newKeylPtr; if (keylPtr->typePtr != &keyedListType.objType) { - if (SetKeyedListFromAny(interp, keylPtr) != TCL_OK) { - return TCL_ERROR; - } + if (SetKeyedListFromAny(interp, keylPtr) != TCL_OK) { + return TCL_ERROR; + } } keylIntPtr = (keylIntObj_t *)keylPtr->internalRep.twoPtrValue.ptr1; KEYL_REP_ASSERT (keylIntPtr); findIdx = FindKeyedListEntry (keylIntPtr, key, - &keyLen, &nextSubKey); + &keyLen, &nextSubKey); /* * If we are at the last subkey, either update or add an entry. */ if (nextSubKey == NULL) { - if (findIdx < 0) { - EnsureKeyedListSpace (keylIntPtr, 1); - findIdx = keylIntPtr->numEntries; - keylIntPtr->numEntries++; - } else { - ckfree (keylIntPtr->entries [findIdx].key); - Tcl_DecrRefCount (keylIntPtr->entries [findIdx].valuePtr); - } - keylIntPtr->entries [findIdx].key = - (char *) ckalloc (keyLen + 1); - strncpy (keylIntPtr->entries [findIdx].key, key, keyLen); - keylIntPtr->entries [findIdx].key [keyLen] = '\0'; - keylIntPtr->entries [findIdx].valuePtr = valuePtr; - Tcl_IncrRefCount (valuePtr); - Tcl_InvalidateStringRep (keylPtr); - - KEYL_REP_ASSERT (keylIntPtr); - return TCL_OK; + if (findIdx < 0) { + EnsureKeyedListSpace (keylIntPtr, 1); + findIdx = keylIntPtr->numEntries; + keylIntPtr->numEntries++; + } else { + ckfree (keylIntPtr->entries [findIdx].key); + Tcl_DecrRefCount (keylIntPtr->entries [findIdx].valuePtr); + } + keylIntPtr->entries [findIdx].key = + (char *) ckalloc (keyLen + 1); + strncpy (keylIntPtr->entries [findIdx].key, key, keyLen); + keylIntPtr->entries [findIdx].key [keyLen] = '\0'; + keylIntPtr->entries [findIdx].valuePtr = valuePtr; + Tcl_IncrRefCount (valuePtr); + Tcl_InvalidateStringRep (keylPtr); + + KEYL_REP_ASSERT (keylIntPtr); + return TCL_OK; } /* @@ -966,36 +966,36 @@ TclX_KeyedListSet( * come back without error. */ if (findIdx >= 0) { - DupSharedKeyListChild (keylIntPtr, findIdx); - status = - TclX_KeyedListSet (interp, - keylIntPtr->entries [findIdx].valuePtr, - nextSubKey, valuePtr); - if (status == TCL_OK) { - Tcl_InvalidateStringRep (keylPtr); - } - - KEYL_REP_ASSERT (keylIntPtr); - return status; + DupSharedKeyListChild (keylIntPtr, findIdx); + status = + TclX_KeyedListSet (interp, + keylIntPtr->entries [findIdx].valuePtr, + nextSubKey, valuePtr); + if (status == TCL_OK) { + Tcl_InvalidateStringRep (keylPtr); + } + + KEYL_REP_ASSERT (keylIntPtr); + return status; } else { - newKeylPtr = TclX_NewKeyedListObj (); - if (TclX_KeyedListSet (interp, newKeylPtr, - nextSubKey, valuePtr) != TCL_OK) { - Tcl_DecrRefCount (newKeylPtr); - return TCL_ERROR; - } - EnsureKeyedListSpace (keylIntPtr, 1); - findIdx = keylIntPtr->numEntries++; - keylIntPtr->entries [findIdx].key = - (char *) ckalloc (keyLen + 1); - strncpy (keylIntPtr->entries [findIdx].key, key, keyLen); - keylIntPtr->entries [findIdx].key [keyLen] = '\0'; - keylIntPtr->entries [findIdx].valuePtr = newKeylPtr; - Tcl_IncrRefCount (newKeylPtr); - Tcl_InvalidateStringRep (keylPtr); - - KEYL_REP_ASSERT (keylIntPtr); - return TCL_OK; + newKeylPtr = TclX_NewKeyedListObj (); + if (TclX_KeyedListSet (interp, newKeylPtr, + nextSubKey, valuePtr) != TCL_OK) { + Tcl_DecrRefCount (newKeylPtr); + return TCL_ERROR; + } + EnsureKeyedListSpace (keylIntPtr, 1); + findIdx = keylIntPtr->numEntries++; + keylIntPtr->entries [findIdx].key = + (char *) ckalloc (keyLen + 1); + strncpy (keylIntPtr->entries [findIdx].key, key, keyLen); + keylIntPtr->entries [findIdx].key [keyLen] = '\0'; + keylIntPtr->entries [findIdx].valuePtr = newKeylPtr; + Tcl_IncrRefCount (newKeylPtr); + Tcl_InvalidateStringRep (keylPtr); + + KEYL_REP_ASSERT (keylIntPtr); + return TCL_OK; } } @@ -1025,9 +1025,9 @@ TclX_KeyedListDelete( int findIdx, status; if (keylPtr->typePtr != &keyedListType.objType) { - if (SetKeyedListFromAny(interp, keylPtr) != TCL_OK) { - return TCL_ERROR; - } + if (SetKeyedListFromAny(interp, keylPtr) != TCL_OK) { + return TCL_ERROR; + } } keylIntPtr = (keylIntObj_t *)keylPtr->internalRep.twoPtrValue.ptr1; @@ -1037,19 +1037,19 @@ TclX_KeyedListDelete( * If not found, return status. */ if (findIdx < 0) { - KEYL_REP_ASSERT (keylIntPtr); - return TCL_BREAK; + KEYL_REP_ASSERT (keylIntPtr); + return TCL_BREAK; } /* * If we are at the last subkey, delete the entry. */ if (nextSubKey == NULL) { - DeleteKeyedListEntry (keylIntPtr, findIdx); - Tcl_InvalidateStringRep (keylPtr); + DeleteKeyedListEntry (keylIntPtr, findIdx); + Tcl_InvalidateStringRep (keylPtr); - KEYL_REP_ASSERT (keylIntPtr); - return TCL_OK; + KEYL_REP_ASSERT (keylIntPtr); + return TCL_OK; } /* @@ -1060,15 +1060,15 @@ TclX_KeyedListDelete( DupSharedKeyListChild (keylIntPtr, findIdx); status = TclX_KeyedListDelete (interp, - keylIntPtr->entries [findIdx].valuePtr, - nextSubKey); + keylIntPtr->entries [findIdx].valuePtr, + nextSubKey); if (status == TCL_OK) { - subKeylIntPtr = (keylIntObj_t *) - keylIntPtr->entries [findIdx].valuePtr->internalRep.twoPtrValue.ptr1; - if (subKeylIntPtr->numEntries == 0) { - DeleteKeyedListEntry (keylIntPtr, findIdx); - } - Tcl_InvalidateStringRep (keylPtr); + subKeylIntPtr = (keylIntObj_t *) + keylIntPtr->entries [findIdx].valuePtr->internalRep.twoPtrValue.ptr1; + if (subKeylIntPtr->numEntries == 0) { + DeleteKeyedListEntry (keylIntPtr, findIdx); + } + Tcl_InvalidateStringRep (keylPtr); } KEYL_REP_ASSERT (keylIntPtr); @@ -1104,9 +1104,9 @@ TclX_KeyedListGetKeys( int idx, findIdx; if (keylPtr->typePtr != &keyedListType.objType) { - if (SetKeyedListFromAny(interp, keylPtr) != TCL_OK) { - return TCL_ERROR; - } + if (SetKeyedListFromAny(interp, keylPtr) != TCL_OK) { + return TCL_ERROR; + } } keylIntPtr = (keylIntObj_t *)keylPtr->internalRep.twoPtrValue.ptr1; @@ -1115,16 +1115,16 @@ TclX_KeyedListGetKeys( * the end of all of the elements of the key. */ if ((key != NULL) && (key [0] != '\0')) { - findIdx = FindKeyedListEntry (keylIntPtr, key, NULL, &nextSubKey); - if (findIdx < 0) { - TclX_Assert (keylIntPtr->arraySize >= keylIntPtr->numEntries); - return TCL_BREAK; - } - TclX_Assert (keylIntPtr->arraySize >= keylIntPtr->numEntries); - return TclX_KeyedListGetKeys (interp, - keylIntPtr->entries [findIdx].valuePtr, - nextSubKey, - listObjPtrPtr); + findIdx = FindKeyedListEntry (keylIntPtr, key, NULL, &nextSubKey); + if (findIdx < 0) { + TclX_Assert (keylIntPtr->arraySize >= keylIntPtr->numEntries); + return TCL_BREAK; + } + TclX_Assert (keylIntPtr->arraySize >= keylIntPtr->numEntries); + return TclX_KeyedListGetKeys (interp, + keylIntPtr->entries [findIdx].valuePtr, + nextSubKey, + listObjPtrPtr); } /* @@ -1132,14 +1132,14 @@ TclX_KeyedListGetKeys( */ listObjPtr = Tcl_NewListObj (0, NULL); for (idx = 0; idx < keylIntPtr->numEntries; idx++) { - nameObjPtr = Tcl_NewStringObj (keylIntPtr->entries [idx].key, - -1); - if (Tcl_ListObjAppendElement (interp, listObjPtr, - nameObjPtr) != TCL_OK) { - Tcl_DecrRefCount (nameObjPtr); - Tcl_DecrRefCount (listObjPtr); - return TCL_ERROR; - } + nameObjPtr = Tcl_NewStringObj (keylIntPtr->entries [idx].key, + -1); + if (Tcl_ListObjAppendElement (interp, listObjPtr, + nameObjPtr) != TCL_OK) { + Tcl_DecrRefCount (nameObjPtr); + Tcl_DecrRefCount (listObjPtr); + return TCL_ERROR; + } } *listObjPtrPtr = listObjPtr; TclX_Assert (keylIntPtr->arraySize >= keylIntPtr->numEntries); @@ -1164,18 +1164,18 @@ Tcl_KeylgetObjCmd( int status; if ((objc < 2) || (objc > 4)) { - return TclX_WrongArgs (interp, objv [0], - "listvar ?key? ?retvar | {}?"); + return TclX_WrongArgs (interp, objv [0], + "listvar ?key? ?retvar | {}?"); } /* * Handle request for list of keys, use keylkeys command. */ if (objc == 2) - return Tcl_KeylkeysObjCmd (clientData, interp, objc, objv); + return Tcl_KeylkeysObjCmd (clientData, interp, objc, objv); keylPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (keylPtr == NULL) { - return TCL_ERROR; + return TCL_ERROR; } /* @@ -1183,44 +1183,44 @@ Tcl_KeylgetObjCmd( */ key = Tcl_GetString(objv[2]); if (ValidateKey(interp, key, objv[2]->length, 1) == TCL_ERROR) { - return TCL_ERROR; + return TCL_ERROR; } status = TclX_KeyedListGet (interp, keylPtr, key, &valuePtr); if (status == TCL_ERROR) - return TCL_ERROR; + return TCL_ERROR; /* * Handle key not found. */ if (status == TCL_BREAK) { - if (objc == 3) { - TclX_AppendObjResult (interp, "key \"", key, - "\" not found in keyed list", - (char *) NULL); - return TCL_ERROR; - } else { - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult (interp), 0); - return TCL_OK; - } + if (objc == 3) { + TclX_AppendObjResult (interp, "key \"", key, + "\" not found in keyed list", + (char *) NULL); + return TCL_ERROR; + } else { + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult (interp), 0); + return TCL_OK; + } } /* * No variable specified, so return value in the result. */ if (objc == 3) { - Tcl_SetObjResult (interp, valuePtr); - return TCL_OK; + Tcl_SetObjResult (interp, valuePtr); + return TCL_OK; } /* * Variable (or empty variable name) specified. */ if (!TclX_IsNullObj(objv [3])) { - if (Tcl_ObjSetVar2(interp, objv[3], NULL, - valuePtr, TCL_LEAVE_ERR_MSG) == NULL) - return TCL_ERROR; + if (Tcl_ObjSetVar2(interp, objv[3], NULL, + valuePtr, TCL_LEAVE_ERR_MSG) == NULL) + return TCL_ERROR; } Tcl_ResetResult(interp); Tcl_SetIntObj(Tcl_GetObjResult (interp), 1); @@ -1246,8 +1246,8 @@ Tcl_KeylsetObjCmd( (void)dummy; if ((objc < 4) || ((objc % 2) != 0)) { - return TclX_WrongArgs (interp, objv [0], - "listvar key value ?key value...?"); + return TclX_WrongArgs (interp, objv [0], + "listvar key value ?key value...?"); } /* @@ -1257,36 +1257,36 @@ Tcl_KeylsetObjCmd( */ keylVarPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); if ((keylVarPtr == NULL) || (Tcl_IsShared (keylVarPtr))) { - if (keylVarPtr == NULL) { - keylVarPtr = TclX_NewKeyedListObj (); - } else { - keylVarPtr = Tcl_DuplicateObj (keylVarPtr); - } - newVarObj = keylVarPtr; + if (keylVarPtr == NULL) { + keylVarPtr = TclX_NewKeyedListObj (); + } else { + keylVarPtr = Tcl_DuplicateObj (keylVarPtr); + } + newVarObj = keylVarPtr; } else { - newVarObj = NULL; + newVarObj = NULL; } for (idx = 2; idx < objc; idx += 2) { - key = Tcl_GetString(objv[idx]); - if (ValidateKey(interp, key, objv[idx]->length, 1) == TCL_ERROR) { - goto errorExit; - } - if (TclX_KeyedListSet (interp, keylVarPtr, key, objv [idx+1]) != TCL_OK) { - goto errorExit; - } + key = Tcl_GetString(objv[idx]); + if (ValidateKey(interp, key, objv[idx]->length, 1) == TCL_ERROR) { + goto errorExit; + } + if (TclX_KeyedListSet (interp, keylVarPtr, key, objv [idx+1]) != TCL_OK) { + goto errorExit; + } } if (Tcl_ObjSetVar2(interp, objv[1], NULL, keylVarPtr, - TCL_LEAVE_ERR_MSG) == NULL) { - goto errorExit; + TCL_LEAVE_ERR_MSG) == NULL) { + goto errorExit; } return TCL_OK; errorExit: if (newVarObj != NULL) { - Tcl_DecrRefCount (newVarObj); + Tcl_DecrRefCount (newVarObj); } return TCL_ERROR; } @@ -1310,7 +1310,7 @@ Tcl_KeyldelObjCmd( (void)dummy; if (objc < 3) { - return TclX_WrongArgs (interp, objv [0], "listvar key ?key ...?"); + return TclX_WrongArgs (interp, objv [0], "listvar key ?key ...?"); } /* @@ -1319,36 +1319,36 @@ Tcl_KeyldelObjCmd( */ keylVarPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (keylVarPtr == NULL) { - return TCL_ERROR; + return TCL_ERROR; } if (Tcl_IsShared (keylVarPtr)) { - keylPtr = Tcl_DuplicateObj (keylVarPtr); - keylVarPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, keylPtr, TCL_LEAVE_ERR_MSG); - if (keylVarPtr == NULL) { - Tcl_DecrRefCount (keylPtr); - return TCL_ERROR; - } - if (keylVarPtr != keylPtr) { - Tcl_DecrRefCount (keylPtr); - } + keylPtr = Tcl_DuplicateObj (keylVarPtr); + keylVarPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, keylPtr, TCL_LEAVE_ERR_MSG); + if (keylVarPtr == NULL) { + Tcl_DecrRefCount (keylPtr); + return TCL_ERROR; + } + if (keylVarPtr != keylPtr) { + Tcl_DecrRefCount (keylPtr); + } } keylPtr = keylVarPtr; for (idx = 2; idx < objc; idx++) { - key = Tcl_GetString(objv[idx]); - if (ValidateKey(interp, key, objv[idx]->length, 1) == TCL_ERROR) { - return TCL_ERROR; - } - - status = TclX_KeyedListDelete (interp, keylPtr, key); - switch (status) { - case TCL_BREAK: - TclX_AppendObjResult (interp, "key not found: \"", - key, "\"", (char *) NULL); - return TCL_ERROR; - case TCL_ERROR: - return TCL_ERROR; - } + key = Tcl_GetString(objv[idx]); + if (ValidateKey(interp, key, objv[idx]->length, 1) == TCL_ERROR) { + return TCL_ERROR; + } + + status = TclX_KeyedListDelete (interp, keylPtr, key); + switch (status) { + case TCL_BREAK: + TclX_AppendObjResult (interp, "key not found: \"", + key, "\"", (char *) NULL); + return TCL_ERROR; + case TCL_ERROR: + return TCL_ERROR; + } } return TCL_OK; @@ -1373,12 +1373,12 @@ Tcl_KeylkeysObjCmd( (void)dummy; if ((objc < 2) || (objc > 3)) { - return TclX_WrongArgs(interp, objv [0], "listvar ?key?"); + return TclX_WrongArgs(interp, objv [0], "listvar ?key?"); } keylPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (keylPtr == NULL) { - return TCL_ERROR; + return TCL_ERROR; } /* @@ -1386,22 +1386,22 @@ Tcl_KeylkeysObjCmd( * meaning get top level keys. */ if (objc < 3) { - key = NULL; + key = NULL; } else { - key = Tcl_GetString(objv[2]); - if (ValidateKey(interp, key, objv[2]->length, 1) == TCL_ERROR) { - return TCL_ERROR; - } + key = Tcl_GetString(objv[2]); + if (ValidateKey(interp, key, objv[2]->length, 1) == TCL_ERROR) { + return TCL_ERROR; + } } status = TclX_KeyedListGetKeys (interp, keylPtr, key, &listObjPtr); switch (status) { case TCL_BREAK: - TclX_AppendObjResult (interp, "key not found: \"", key, "\"", - (char *) NULL); - return TCL_ERROR; + TclX_AppendObjResult (interp, "key not found: \"", key, "\"", + (char *) NULL); + return TCL_ERROR; case TCL_ERROR: - return TCL_ERROR; + return TCL_ERROR; } Tcl_SetObjResult (interp, listObjPtr); @@ -1431,28 +1431,28 @@ TclX_KeyedListInit( if (0) { Tcl_CreateObjCommand (interp, - "keylget", - Tcl_KeylgetObjCmd, - NULL, - NULL); + "keylget", + Tcl_KeylgetObjCmd, + NULL, + NULL); Tcl_CreateObjCommand (interp, - "keylset", - Tcl_KeylsetObjCmd, - NULL, - NULL); + "keylset", + Tcl_KeylsetObjCmd, + NULL, + NULL); Tcl_CreateObjCommand (interp, - "keyldel", - Tcl_KeyldelObjCmd, - NULL, - NULL); + "keyldel", + Tcl_KeyldelObjCmd, + NULL, + NULL); Tcl_CreateObjCommand (interp, - "keylkeys", - Tcl_KeylkeysObjCmd, - NULL, - NULL); + "keylkeys", + Tcl_KeylkeysObjCmd, + NULL, + NULL); } } diff --git a/generic/threadCmd.c b/generic/threadCmd.c index 6908839..ce10e43 100644 --- a/generic/threadCmd.c +++ b/generic/threadCmd.c @@ -58,7 +58,7 @@ typedef struct ThreadSpecificData { Tcl_ThreadId threadId; /* The real ID of this thread */ Tcl_Interp *interp; /* Main interp for this thread */ Tcl_Condition doOneEvent; /* Signalled just before running - an event from the event loop */ + an event from the event loop */ int flags; /* One of the ThreadFlags below */ size_t refCount; /* Used for thread reservation */ int eventsPending; /* # of unprocessed events */ @@ -108,9 +108,9 @@ int threadTclVersion = 0; typedef struct ThreadCtrl { char *script; /* Script to execute */ int flags; /* Initial value of the "flags" - * field in ThreadSpecificData */ + * field in ThreadSpecificData */ Tcl_Condition condWait; /* Condition variable used to - * sync parent and child threads */ + * sync parent and child threads */ void *cd; /* Opaque ptr to pass to thread */ } ThreadCtrl; @@ -148,7 +148,7 @@ typedef struct ThreadEvent { struct ThreadSendData *sendData; /* See below */ struct ThreadClbkData *clbkData; /* See below */ struct ThreadEventResult *resultPtr; /* To communicate the result back. - * NULL if we don't care about it */ + * NULL if we don't care about it */ } ThreadEvent; typedef int (ThreadSendProc) (Tcl_Interp*, void *); @@ -196,10 +196,10 @@ typedef struct TransferEvent { typedef struct TransferResult { Tcl_Condition done; /* Set when transfer is done */ int resultCode; /* Set to TCL_OK or TCL_ERROR when - the transfer is done. Def = -1 */ + the transfer is done. Def = -1 */ char *resultMsg; /* Initialized to NULL. Set to a - allocated string by the target - thread in case of an error */ + allocated string by the target + thread in case of an error */ Tcl_ThreadId srcThreadId; /* Id of src thread, if it dies */ Tcl_ThreadId dstThreadId; /* Id of tgt thread, if it dies */ struct TransferEvent *eventPtr; /* Back pointer */ @@ -246,38 +246,38 @@ ThreadInit(Tcl_Interp *interp); static int ThreadCreate(Tcl_Interp *interp, - const char *script, - TCL_HASH_TYPE stacksize, - int flags, - int preserve); + const char *script, + TCL_HASH_TYPE stacksize, + int flags, + int preserve); static int ThreadSend(Tcl_Interp *interp, - Tcl_ThreadId id, - ThreadSendData *sendPtr, - ThreadClbkData *clbkPtr, - int flags); + Tcl_ThreadId id, + ThreadSendData *sendPtr, + ThreadClbkData *clbkPtr, + int flags); static void ThreadSetResult(Tcl_Interp *interp, - int code, - ThreadEventResult *resultPtr); + int code, + ThreadEventResult *resultPtr); static int ThreadGetOption(Tcl_Interp *interp, - Tcl_ThreadId id, - char *option, - Tcl_DString *ds); + Tcl_ThreadId id, + char *option, + Tcl_DString *ds); static int ThreadSetOption(Tcl_Interp *interp, - Tcl_ThreadId id, - char *option, - char *value); + Tcl_ThreadId id, + char *option, + char *value); static int ThreadReserve(Tcl_Interp *interp, - Tcl_ThreadId id, - int operation, - int wait); + Tcl_ThreadId id, + int operation, + int wait); static int ThreadEventProc(Tcl_Event *evPtr, - int mask); + int mask); static int ThreadWait(Tcl_Interp *interp); @@ -286,7 +286,7 @@ ThreadExists(Tcl_ThreadId id); static int ThreadList(Tcl_Interp *interp, - Tcl_ThreadId **thrIdArray); + Tcl_ThreadId **thrIdArray); static void ThreadErrorProc(Tcl_Interp *interp); @@ -313,41 +313,41 @@ ListUpdateInner(ThreadSpecificData *tsdPtr); static int ThreadJoin(Tcl_Interp *interp, - Tcl_ThreadId id); + Tcl_ThreadId id); static int ThreadTransfer(Tcl_Interp *interp, - Tcl_ThreadId id, - Tcl_Channel chan); + Tcl_ThreadId id, + Tcl_Channel chan); static int ThreadDetach(Tcl_Interp *interp, - Tcl_Channel chan); + Tcl_Channel chan); static int ThreadAttach(Tcl_Interp *interp, - char *chanName); + char *chanName); static int TransferEventProc(Tcl_Event *evPtr, - int mask); + int mask); static void ThreadGetHandle(Tcl_ThreadId, - char *handlePtr); + char *handlePtr); static int ThreadGetId(Tcl_Interp *interp, - Tcl_Obj *handleObj, - Tcl_ThreadId *thrIdPtr); + Tcl_Obj *handleObj, + Tcl_ThreadId *thrIdPtr); static void ErrorNoSuchThread(Tcl_Interp *interp, - Tcl_ThreadId thrId); + Tcl_ThreadId thrId); static void ThreadCutChannel(Tcl_Interp *interp, - Tcl_Channel channel); + Tcl_Channel channel); static int ThreadCancel(Tcl_Interp *interp, - Tcl_ThreadId thrId, - const char *result, - int flags); + Tcl_ThreadId thrId, + const char *result, + int flags); /* * Functions implementing Tcl commands @@ -1525,7 +1525,7 @@ ThreadConfigureObjCmd( Tcl_ThreadId thrId; /* Id of the thread to configure */ int i; /* Iterate over arg-value pairs. */ Tcl_DString ds; /* DString to hold result of - * calling GetThreadOption. */ + * calling GetThreadOption. */ if (objc < 2 || (objc % 2 == 1 && objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "threadlId ?optionName? " @@ -1687,7 +1687,7 @@ ThreadClbkSetVar( Tcl_IncrRefCount(valObj); if (resultPtr->result != threadEmptyResult) { - ckfree(resultPtr->result); + ckfree(resultPtr->result); } /* @@ -2873,7 +2873,7 @@ ThreadSend( Tcl_ConditionFinalize(&resultPtr->done); if (resultPtr->result != threadEmptyResult) { - ckfree(resultPtr->result); + ckfree(resultPtr->result); } ckfree((char*)resultPtr); diff --git a/generic/threadPoolCmd.c b/generic/threadPoolCmd.c index 5d8acda..e7502db 100644 --- a/generic/threadPoolCmd.c +++ b/generic/threadPoolCmd.c @@ -143,7 +143,7 @@ SignalWaiter(ThreadPool *tpoolPtr); static int TpoolEval(Tcl_Interp *interp, char *script, size_t scriptLen, - TpoolResult *rPtr); + TpoolResult *rPtr); static void SetResult(Tcl_Interp *interp, TpoolResult *rPtr); @@ -212,7 +212,7 @@ TpoolCreateObjCmd( */ if (((objc-1) % 2)) { - goto usage; + goto usage; } minw = TPOOL_MINWORKERS; @@ -224,28 +224,28 @@ TpoolCreateObjCmd( */ for (ii = 1; ii < objc; ii += 2) { - char *opt = Tcl_GetString(objv[ii]); - if (OPT_CMP(opt, "-minworkers")) { - if (Tcl_GetIntFromObj(interp, objv[ii+1], &minw) != TCL_OK) { - return TCL_ERROR; - } - } else if (OPT_CMP(opt, "-maxworkers")) { - if (Tcl_GetIntFromObj(interp, objv[ii+1], &maxw) != TCL_OK) { - return TCL_ERROR; - } - } else if (OPT_CMP(opt, "-idletime")) { - if (Tcl_GetIntFromObj(interp, objv[ii+1], &idle) != TCL_OK) { - return TCL_ERROR; - } - } else if (OPT_CMP(opt, "-initcmd")) { - const char *val = Tcl_GetString(objv[ii+1]); - cmd = strcpy((char *)ckalloc(objv[ii+1]->length+1), val); - } else if (OPT_CMP(opt, "-exitcmd")) { - const char *val = Tcl_GetString(objv[ii+1]); - exs = strcpy((char *)ckalloc(objv[ii+1]->length+1), val); - } else { - goto usage; - } + char *opt = Tcl_GetString(objv[ii]); + if (OPT_CMP(opt, "-minworkers")) { + if (Tcl_GetIntFromObj(interp, objv[ii+1], &minw) != TCL_OK) { + return TCL_ERROR; + } + } else if (OPT_CMP(opt, "-maxworkers")) { + if (Tcl_GetIntFromObj(interp, objv[ii+1], &maxw) != TCL_OK) { + return TCL_ERROR; + } + } else if (OPT_CMP(opt, "-idletime")) { + if (Tcl_GetIntFromObj(interp, objv[ii+1], &idle) != TCL_OK) { + return TCL_ERROR; + } + } else if (OPT_CMP(opt, "-initcmd")) { + const char *val = Tcl_GetString(objv[ii+1]); + cmd = strcpy((char *)ckalloc(objv[ii+1]->length+1), val); + } else if (OPT_CMP(opt, "-exitcmd")) { + const char *val = Tcl_GetString(objv[ii+1]); + exs = strcpy((char *)ckalloc(objv[ii+1]->length+1), val); + } else { + goto usage; + } } /* @@ -253,13 +253,13 @@ TpoolCreateObjCmd( */ if (minw < 0) { - minw = 0; + minw = 0; } if (maxw < 0) { - maxw = TPOOL_MAXWORKERS; + maxw = TPOOL_MAXWORKERS; } if (minw > maxw) { - maxw = minw; + maxw = minw; } /* @@ -288,13 +288,13 @@ TpoolCreateObjCmd( Tcl_MutexLock(&tpoolPtr->mutex); for (ii = 0; ii < tpoolPtr->minWorkers; ii++) { - if (CreateWorker(interp, tpoolPtr) != TCL_OK) { - Tcl_MutexUnlock(&tpoolPtr->mutex); - Tcl_MutexLock(&listMutex); - TpoolRelease(tpoolPtr); - Tcl_MutexUnlock(&listMutex); - return TCL_ERROR; - } + if (CreateWorker(interp, tpoolPtr) != TCL_OK) { + Tcl_MutexUnlock(&tpoolPtr->mutex); + Tcl_MutexLock(&listMutex); + TpoolRelease(tpoolPtr); + Tcl_MutexUnlock(&listMutex); + return TCL_ERROR; + } } Tcl_MutexUnlock(&tpoolPtr->mutex); @@ -305,9 +305,9 @@ TpoolCreateObjCmd( usage: Tcl_WrongNumArgs(interp, 1, objv, - "?-minworkers count? ?-maxworkers count? " - "?-initcmd script? ?-exitcmd script? " - "?-idletime seconds?"); + "?-minworkers count? ?-maxworkers count? " + "?-initcmd script? ?-exitcmd script? " + "?-idletime seconds?"); return TCL_ERROR; } @@ -349,19 +349,19 @@ TpoolPostObjCmd( */ if (objc < 3 || objc > 5) { - goto usage; + goto usage; } for (ii = 1; ii < objc; ii++) { - char *opt = Tcl_GetString(objv[ii]); - if (*opt != '-') { - break; - } else if (OPT_CMP(opt, "-detached")) { - detached = 1; - } else if (OPT_CMP(opt, "-nowait")) { - nowait = 1; - } else { - goto usage; - } + char *opt = Tcl_GetString(objv[ii]); + if (*opt != '-') { + break; + } else if (OPT_CMP(opt, "-detached")) { + detached = 1; + } else if (OPT_CMP(opt, "-nowait")) { + nowait = 1; + } else { + goto usage; + } } /* @@ -369,7 +369,7 @@ TpoolPostObjCmd( */ if (objc - ii != 2) { - goto usage; + goto usage; } tpoolName = Tcl_GetString(objv[ii]); @@ -377,9 +377,9 @@ TpoolPostObjCmd( len = objv[ii+1]->length; tpoolPtr = GetTpool(tpoolName); if (tpoolPtr == NULL) { - Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, - "\"", (void *)NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, + "\"", (void *)NULL); + return TCL_ERROR; } /* @@ -394,62 +394,62 @@ TpoolPostObjCmd( Tcl_MutexLock(&tpoolPtr->mutex); if (nowait) { - if (tpoolPtr->numWorkers == 0) { - - /* - * Assure there is at least one worker running. - */ - - PushWaiter(tpoolPtr); - if (CreateWorker(interp, tpoolPtr) != TCL_OK) { - Tcl_MutexUnlock(&tpoolPtr->mutex); - return TCL_ERROR; - } - - /* - * Wait for worker to start while servicing the event loop - */ - - Tcl_MutexUnlock(&tpoolPtr->mutex); - tsdPtr->stop = -1; - while(tsdPtr->stop == -1) { - Tcl_DoOneEvent(TCL_ALL_EVENTS); - } - Tcl_MutexLock(&tpoolPtr->mutex); - } + if (tpoolPtr->numWorkers == 0) { + + /* + * Assure there is at least one worker running. + */ + + PushWaiter(tpoolPtr); + if (CreateWorker(interp, tpoolPtr) != TCL_OK) { + Tcl_MutexUnlock(&tpoolPtr->mutex); + return TCL_ERROR; + } + + /* + * Wait for worker to start while servicing the event loop + */ + + Tcl_MutexUnlock(&tpoolPtr->mutex); + tsdPtr->stop = -1; + while(tsdPtr->stop == -1) { + Tcl_DoOneEvent(TCL_ALL_EVENTS); + } + Tcl_MutexLock(&tpoolPtr->mutex); + } } else { - /* - * If there are no idle worker threads, start some new - * unless we are already running max number of workers. - * In that case wait for the next one to become idle. - */ + /* + * If there are no idle worker threads, start some new + * unless we are already running max number of workers. + * In that case wait for the next one to become idle. + */ - while (tpoolPtr->idleWorkers == 0) { - PushWaiter(tpoolPtr); - if (tpoolPtr->numWorkers < tpoolPtr->maxWorkers) { + while (tpoolPtr->idleWorkers == 0) { + PushWaiter(tpoolPtr); + if (tpoolPtr->numWorkers < tpoolPtr->maxWorkers) { - /* - * No more free workers; start new one - */ + /* + * No more free workers; start new one + */ - if (CreateWorker(interp, tpoolPtr) != TCL_OK) { - Tcl_MutexUnlock(&tpoolPtr->mutex); - return TCL_ERROR; - } - } + if (CreateWorker(interp, tpoolPtr) != TCL_OK) { + Tcl_MutexUnlock(&tpoolPtr->mutex); + return TCL_ERROR; + } + } - /* - * Wait for worker to start while servicing the event loop - */ + /* + * Wait for worker to start while servicing the event loop + */ - Tcl_MutexUnlock(&tpoolPtr->mutex); - tsdPtr->stop = -1; - while(tsdPtr->stop == -1) { - Tcl_DoOneEvent(TCL_ALL_EVENTS); - } - Tcl_MutexLock(&tpoolPtr->mutex); - } + Tcl_MutexUnlock(&tpoolPtr->mutex); + tsdPtr->stop = -1; + while(tsdPtr->stop == -1) { + Tcl_DoOneEvent(TCL_ALL_EVENTS); + } + Tcl_MutexLock(&tpoolPtr->mutex); + } } /* @@ -460,8 +460,8 @@ TpoolPostObjCmd( memset(rPtr, 0, sizeof(TpoolResult)); if (detached == 0) { - jobId = ++tpoolPtr->jobId; - rPtr->jobId = jobId; + jobId = ++tpoolPtr->jobId; + rPtr->jobId = jobId; } rPtr->script = strcpy((char *)ckalloc(len+1), script); @@ -474,7 +474,7 @@ TpoolPostObjCmd( Tcl_MutexUnlock(&tpoolPtr->mutex); if (detached == 0) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(jobId)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(jobId)); } return TCL_OK; @@ -523,21 +523,21 @@ TpoolWaitObjCmd( */ if (objc < 3 || objc > 4) { - Tcl_WrongNumArgs(interp, 1, objv, "tpoolId jobIdList ?listVar"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "tpoolId jobIdList ?listVar"); + return TCL_ERROR; } if (objc == 4) { - listVar = objv[3]; + listVar = objv[3]; } if (Tcl_ListObjGetElements(interp, objv[2], &wObjc, &wObjv) != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } tpoolName = Tcl_GetString(objv[1]); tpoolPtr = GetTpool(tpoolName); if (tpoolPtr == NULL) { - Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, - "\"", (void *)NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, + "\"", (void *)NULL); + return TCL_ERROR; } InitWaiter(); @@ -546,52 +546,52 @@ TpoolWaitObjCmd( Tcl_MutexLock(&tpoolPtr->mutex); while (1) { - waitList = Tcl_NewListObj(0, NULL); - for (ii = 0; ii < wObjc; ii++) { - if (Tcl_GetWideIntFromObj(interp, wObjv[ii], &jobId) != TCL_OK) { - Tcl_MutexUnlock(&tpoolPtr->mutex); - return TCL_ERROR; - } - hPtr = Tcl_FindHashEntry(&tpoolPtr->jobsDone, (void *)(size_t)jobId); - if (hPtr) { - rPtr = (TpoolResult*)Tcl_GetHashValue(hPtr); - } else { - rPtr = NULL; - } - if (rPtr == NULL) { - if (listVar) { - Tcl_ListObjAppendElement(interp, waitList, wObjv[ii]); - } - } else if (!rPtr->detached && rPtr->result) { - done++; - Tcl_ListObjAppendElement(interp, doneList, wObjv[ii]); - } else if (listVar) { - Tcl_ListObjAppendElement(interp, waitList, wObjv[ii]); - } - } - if (done) { - break; - } - - /* - * None of the jobs done, wait for completion - * of the next job and try again. - */ - - Tcl_DecrRefCount(waitList); - PushWaiter(tpoolPtr); - - Tcl_MutexUnlock(&tpoolPtr->mutex); - tsdPtr->stop = -1; - while (tsdPtr->stop == -1) { - Tcl_DoOneEvent(TCL_ALL_EVENTS); - } - Tcl_MutexLock(&tpoolPtr->mutex); + waitList = Tcl_NewListObj(0, NULL); + for (ii = 0; ii < wObjc; ii++) { + if (Tcl_GetWideIntFromObj(interp, wObjv[ii], &jobId) != TCL_OK) { + Tcl_MutexUnlock(&tpoolPtr->mutex); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&tpoolPtr->jobsDone, (void *)(size_t)jobId); + if (hPtr) { + rPtr = (TpoolResult*)Tcl_GetHashValue(hPtr); + } else { + rPtr = NULL; + } + if (rPtr == NULL) { + if (listVar) { + Tcl_ListObjAppendElement(interp, waitList, wObjv[ii]); + } + } else if (!rPtr->detached && rPtr->result) { + done++; + Tcl_ListObjAppendElement(interp, doneList, wObjv[ii]); + } else if (listVar) { + Tcl_ListObjAppendElement(interp, waitList, wObjv[ii]); + } + } + if (done) { + break; + } + + /* + * None of the jobs done, wait for completion + * of the next job and try again. + */ + + Tcl_DecrRefCount(waitList); + PushWaiter(tpoolPtr); + + Tcl_MutexUnlock(&tpoolPtr->mutex); + tsdPtr->stop = -1; + while (tsdPtr->stop == -1) { + Tcl_DoOneEvent(TCL_ALL_EVENTS); + } + Tcl_MutexLock(&tpoolPtr->mutex); } Tcl_MutexUnlock(&tpoolPtr->mutex); if (listVar) { - Tcl_ObjSetVar2(interp, listVar, NULL, waitList, 0); + Tcl_ObjSetVar2(interp, listVar, NULL, waitList, 0); } Tcl_SetObjResult(interp, doneList); @@ -635,21 +635,21 @@ TpoolCancelObjCmd( */ if (objc < 3 || objc > 4) { - Tcl_WrongNumArgs(interp, 1, objv, "tpoolId jobIdList ?listVar"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "tpoolId jobIdList ?listVar"); + return TCL_ERROR; } if (objc == 4) { - listVar = objv[3]; + listVar = objv[3]; } if (Tcl_ListObjGetElements(interp, objv[2], &wObjc, &wObjv) != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } tpoolName = Tcl_GetString(objv[1]); tpoolPtr = GetTpool(tpoolName); if (tpoolPtr == NULL) { - Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, - "\"", (void *)NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, + "\"", (void *)NULL); + return TCL_ERROR; } InitWaiter(); @@ -658,36 +658,36 @@ TpoolCancelObjCmd( Tcl_MutexLock(&tpoolPtr->mutex); for (ii = 0; ii < wObjc; ii++) { - if (Tcl_GetWideIntFromObj(interp, wObjv[ii], &jobId) != TCL_OK) { - return TCL_ERROR; - } - for (rPtr = tpoolPtr->workHead; rPtr; rPtr = rPtr->nextPtr) { - if (rPtr->jobId == jobId) { - if (rPtr->prevPtr != NULL) { - rPtr->prevPtr->nextPtr = rPtr->nextPtr; - } else { - tpoolPtr->workHead = rPtr->nextPtr; - } - if (rPtr->nextPtr != NULL) { - rPtr->nextPtr->prevPtr = rPtr->prevPtr; - } else { - tpoolPtr->workTail = rPtr->prevPtr; - } - SetResult(NULL, rPtr); /* Just to free the result */ - ckfree(rPtr->script); - ckfree((char *)rPtr); - Tcl_ListObjAppendElement(interp, doneList, wObjv[ii]); - break; - } - } - if (rPtr == NULL && listVar) { - Tcl_ListObjAppendElement(interp, waitList, wObjv[ii]); - } + if (Tcl_GetWideIntFromObj(interp, wObjv[ii], &jobId) != TCL_OK) { + return TCL_ERROR; + } + for (rPtr = tpoolPtr->workHead; rPtr; rPtr = rPtr->nextPtr) { + if (rPtr->jobId == jobId) { + if (rPtr->prevPtr != NULL) { + rPtr->prevPtr->nextPtr = rPtr->nextPtr; + } else { + tpoolPtr->workHead = rPtr->nextPtr; + } + if (rPtr->nextPtr != NULL) { + rPtr->nextPtr->prevPtr = rPtr->prevPtr; + } else { + tpoolPtr->workTail = rPtr->prevPtr; + } + SetResult(NULL, rPtr); /* Just to free the result */ + ckfree(rPtr->script); + ckfree((char *)rPtr); + Tcl_ListObjAppendElement(interp, doneList, wObjv[ii]); + break; + } + } + if (rPtr == NULL && listVar) { + Tcl_ListObjAppendElement(interp, waitList, wObjv[ii]); + } } Tcl_MutexUnlock(&tpoolPtr->mutex); if (listVar) { - Tcl_ObjSetVar2(interp, listVar, NULL, waitList, 0); + Tcl_ObjSetVar2(interp, listVar, NULL, waitList, 0); } Tcl_SetObjResult(interp, doneList); @@ -731,14 +731,14 @@ TpoolGetObjCmd( */ if (objc < 3 || objc > 4) { - Tcl_WrongNumArgs(interp, 1, objv, "tpoolId jobId ?result?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "tpoolId jobId ?result?"); + return TCL_ERROR; } if (Tcl_GetWideIntFromObj(interp, objv[2], &jobId) != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } if (objc == 4) { - resVar = objv[3]; + resVar = objv[3]; } /* @@ -748,9 +748,9 @@ TpoolGetObjCmd( tpoolName = Tcl_GetString(objv[1]); tpoolPtr = GetTpool(tpoolName); if (tpoolPtr == NULL) { - Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, - "\"", (void *)NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, + "\"", (void *)NULL); + return TCL_ERROR; } /* @@ -762,15 +762,15 @@ TpoolGetObjCmd( Tcl_MutexLock(&tpoolPtr->mutex); hPtr = Tcl_FindHashEntry(&tpoolPtr->jobsDone, (void *)(size_t)jobId); if (hPtr == NULL) { - Tcl_MutexUnlock(&tpoolPtr->mutex); - Tcl_AppendResult(interp, "no such job", (void *)NULL); - return TCL_ERROR; + Tcl_MutexUnlock(&tpoolPtr->mutex); + Tcl_AppendResult(interp, "no such job", (void *)NULL); + return TCL_ERROR; } rPtr = (TpoolResult*)Tcl_GetHashValue(hPtr); if (rPtr->result == NULL) { - Tcl_MutexUnlock(&tpoolPtr->mutex); - Tcl_AppendResult(interp, "job not completed", (void *)NULL); - return TCL_ERROR; + Tcl_MutexUnlock(&tpoolPtr->mutex); + Tcl_AppendResult(interp, "job not completed", (void *)NULL); + return TCL_ERROR; } Tcl_DeleteHashEntry(hPtr); @@ -781,9 +781,9 @@ TpoolGetObjCmd( ckfree((char *)rPtr); if (resVar) { - Tcl_ObjSetVar2(interp, resVar, NULL, Tcl_GetObjResult(interp), 0); - Tcl_SetObjResult(interp, Tcl_NewIntObj(ret)); - ret = TCL_OK; + Tcl_ObjSetVar2(interp, resVar, NULL, Tcl_GetObjResult(interp), 0); + Tcl_SetObjResult(interp, Tcl_NewIntObj(ret)); + ret = TCL_OK; } return ret; @@ -822,8 +822,8 @@ TpoolReserveObjCmd( */ if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "tpoolId"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "tpoolId"); + return TCL_ERROR; } tpoolName = Tcl_GetString(objv[1]); @@ -831,10 +831,10 @@ TpoolReserveObjCmd( Tcl_MutexLock(&listMutex); tpoolPtr = GetTpoolUnl(tpoolName); if (tpoolPtr == NULL) { - Tcl_MutexUnlock(&listMutex); - Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, - "\"", (void *)NULL); - return TCL_ERROR; + Tcl_MutexUnlock(&listMutex); + Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, + "\"", (void *)NULL); + return TCL_ERROR; } ret = TpoolReserve(tpoolPtr); @@ -877,8 +877,8 @@ TpoolReleaseObjCmd( */ if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "tpoolId"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "tpoolId"); + return TCL_ERROR; } tpoolName = Tcl_GetString(objv[1]); @@ -886,10 +886,10 @@ TpoolReleaseObjCmd( Tcl_MutexLock(&listMutex); tpoolPtr = GetTpoolUnl(tpoolName); if (tpoolPtr == NULL) { - Tcl_MutexUnlock(&listMutex); - Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, - "\"", (void *)NULL); - return TCL_ERROR; + Tcl_MutexUnlock(&listMutex); + Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, + "\"", (void *)NULL); + return TCL_ERROR; } ret = TpoolRelease(tpoolPtr); @@ -931,17 +931,17 @@ TpoolSuspendObjCmd( */ if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "tpoolId"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "tpoolId"); + return TCL_ERROR; } tpoolName = Tcl_GetString(objv[1]); tpoolPtr = GetTpool(tpoolName); if (tpoolPtr == NULL) { - Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, - "\"", (void *)NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, + "\"", (void *)NULL); + return TCL_ERROR; } TpoolSuspend(tpoolPtr); @@ -981,17 +981,17 @@ TpoolResumeObjCmd( */ if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "tpoolId"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "tpoolId"); + return TCL_ERROR; } tpoolName = Tcl_GetString(objv[1]); tpoolPtr = GetTpool(tpoolName); if (tpoolPtr == NULL) { - Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, - "\"", (void *)NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, + "\"", (void *)NULL); + return TCL_ERROR; } TpoolResume(tpoolPtr); @@ -1030,9 +1030,9 @@ TpoolNamesObjCmd( Tcl_MutexLock(&listMutex); for (tpoolPtr = tpoolList; tpoolPtr; tpoolPtr = tpoolPtr->nextPtr) { - char buf[32]; - snprintf(buf, sizeof(buf), "%s%p", TPOOL_HNDLPREFIX, tpoolPtr); - Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(buf, TCL_INDEX_NONE)); + char buf[32]; + snprintf(buf, sizeof(buf), "%s%p", TPOOL_HNDLPREFIX, tpoolPtr); + Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(buf, TCL_INDEX_NONE)); } Tcl_MutexUnlock(&listMutex); Tcl_SetObjResult(interp, listObj); @@ -1081,13 +1081,13 @@ CreateWorker( Tcl_MutexLock(&startMutex); if (Tcl_CreateThread(&id, TpoolWorker, &result, - TCL_THREAD_STACK_DEFAULT, 0) != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create a new thread", TCL_INDEX_NONE)); - Tcl_MutexUnlock(&startMutex); - return TCL_ERROR; + TCL_THREAD_STACK_DEFAULT, 0) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create a new thread", TCL_INDEX_NONE)); + Tcl_MutexUnlock(&startMutex); + return TCL_ERROR; } while(result.retcode == -1) { - Tcl_ConditionWait(&tpoolPtr->cond, &startMutex, NULL); + Tcl_ConditionWait(&tpoolPtr->cond, &startMutex, NULL); } Tcl_MutexUnlock(&startMutex); @@ -1097,9 +1097,9 @@ CreateWorker( */ if (result.retcode == 1) { - result.retcode = TCL_ERROR; - SetResult(interp, &result); - return TCL_ERROR; + result.retcode = TCL_ERROR; + SetResult(interp, &result); + return TCL_ERROR; } return TCL_OK; @@ -1145,20 +1145,20 @@ TpoolWorker( #else interp = Tcl_CreateInterp(); if (Tcl_Init(interp) != TCL_OK) { - rPtr->retcode = 1; + rPtr->retcode = 1; } else if (Thread_Init(interp) != TCL_OK) { - rPtr->retcode = 1; + rPtr->retcode = 1; } else { - rPtr->retcode = 0; + rPtr->retcode = 0; } #endif if (rPtr->retcode == 1) { - errMsg = Tcl_GetString(Tcl_GetObjResult(interp)); - rPtr->result = strcpy((char *)ckalloc(strlen(errMsg)+1), errMsg); - Tcl_ConditionNotify(&tpoolPtr->cond); - Tcl_MutexUnlock(&startMutex); - goto out; + errMsg = Tcl_GetString(Tcl_GetObjResult(interp)); + rPtr->result = strcpy((char *)ckalloc(strlen(errMsg)+1), errMsg); + Tcl_ConditionNotify(&tpoolPtr->cond); + Tcl_MutexUnlock(&startMutex); + goto out; } /* @@ -1166,15 +1166,15 @@ TpoolWorker( */ if (tpoolPtr->initScript) { - TpoolEval(interp, tpoolPtr->initScript, -1, rPtr); - if (rPtr->retcode != TCL_OK) { - rPtr->retcode = 1; - errMsg = Tcl_GetString(Tcl_GetObjResult(interp)); - rPtr->result = strcpy((char *)ckalloc(strlen(errMsg)+1), errMsg); - Tcl_ConditionNotify(&tpoolPtr->cond); - Tcl_MutexUnlock(&startMutex); - goto out; - } + TpoolEval(interp, tpoolPtr->initScript, -1, rPtr); + if (rPtr->retcode != TCL_OK) { + rPtr->retcode = 1; + errMsg = Tcl_GetString(Tcl_GetObjResult(interp)); + rPtr->result = strcpy((char *)ckalloc(strlen(errMsg)+1), errMsg); + Tcl_ConditionNotify(&tpoolPtr->cond); + Tcl_MutexUnlock(&startMutex); + goto out; + } } /* @@ -1182,11 +1182,11 @@ TpoolWorker( */ if (tpoolPtr->idleTime == 0) { - idlePtr = NULL; + idlePtr = NULL; } else { - waitTime.sec = tpoolPtr->idleTime; - waitTime.usec = 0; - idlePtr = &waitTime; + waitTime.sec = tpoolPtr->idleTime; + waitTime.usec = 0; + idlePtr = &waitTime; } /* @@ -1206,49 +1206,49 @@ TpoolWorker( Tcl_MutexLock(&tpoolPtr->mutex); while (!tpoolPtr->tearDown) { - SignalWaiter(tpoolPtr); - tpoolPtr->idleWorkers++; - rPtr = NULL; - tout = 0; - while (tpoolPtr->suspend - || (!tpoolPtr->tearDown && !tout - && (rPtr = PopWork(tpoolPtr)) == NULL)) { - if (tpoolPtr->suspend && rPtr == NULL) { - Tcl_ConditionWait(&tpoolPtr->cond, &tpoolPtr->mutex, NULL); - } else if (rPtr == NULL) { - Tcl_Time t1, t2; - Tcl_GetTime(&t1); - Tcl_ConditionWait(&tpoolPtr->cond, &tpoolPtr->mutex, idlePtr); - Tcl_GetTime(&t2); - if (tpoolPtr->idleTime > 0) { - tout = (t2.sec - t1.sec) >= tpoolPtr->idleTime; - } - } - } - tpoolPtr->idleWorkers--; - if (rPtr == NULL) { - if (tpoolPtr->numWorkers > tpoolPtr->minWorkers) { - break; /* Enough workers, can safely kill this one */ - } else { - continue; /* Worker count at min, leave this one alive */ - } - } else if (tpoolPtr->tearDown) { - PushWork(rPtr, tpoolPtr); - break; /* Kill worker because pool is going down */ - } - Tcl_MutexUnlock(&tpoolPtr->mutex); - TpoolEval(interp, rPtr->script, rPtr->scriptLen, rPtr); - ckfree(rPtr->script); - Tcl_MutexLock(&tpoolPtr->mutex); - if (!rPtr->detached) { - int isNew; - Tcl_SetHashValue(Tcl_CreateHashEntry(&tpoolPtr->jobsDone, - (void *)(size_t)rPtr->jobId, &isNew), - rPtr); - SignalWaiter(tpoolPtr); - } else { - ckfree((char*)rPtr); - } + SignalWaiter(tpoolPtr); + tpoolPtr->idleWorkers++; + rPtr = NULL; + tout = 0; + while (tpoolPtr->suspend + || (!tpoolPtr->tearDown && !tout + && (rPtr = PopWork(tpoolPtr)) == NULL)) { + if (tpoolPtr->suspend && rPtr == NULL) { + Tcl_ConditionWait(&tpoolPtr->cond, &tpoolPtr->mutex, NULL); + } else if (rPtr == NULL) { + Tcl_Time t1, t2; + Tcl_GetTime(&t1); + Tcl_ConditionWait(&tpoolPtr->cond, &tpoolPtr->mutex, idlePtr); + Tcl_GetTime(&t2); + if (tpoolPtr->idleTime > 0) { + tout = (t2.sec - t1.sec) >= tpoolPtr->idleTime; + } + } + } + tpoolPtr->idleWorkers--; + if (rPtr == NULL) { + if (tpoolPtr->numWorkers > tpoolPtr->minWorkers) { + break; /* Enough workers, can safely kill this one */ + } else { + continue; /* Worker count at min, leave this one alive */ + } + } else if (tpoolPtr->tearDown) { + PushWork(rPtr, tpoolPtr); + break; /* Kill worker because pool is going down */ + } + Tcl_MutexUnlock(&tpoolPtr->mutex); + TpoolEval(interp, rPtr->script, rPtr->scriptLen, rPtr); + ckfree(rPtr->script); + Tcl_MutexLock(&tpoolPtr->mutex); + if (!rPtr->detached) { + int isNew; + Tcl_SetHashValue(Tcl_CreateHashEntry(&tpoolPtr->jobsDone, + (void *)(size_t)rPtr->jobId, &isNew), + rPtr); + SignalWaiter(tpoolPtr); + } else { + ckfree((char*)rPtr); + } } /* @@ -1256,7 +1256,7 @@ TpoolWorker( */ if (tpoolPtr->exitScript) { - TpoolEval(interp, tpoolPtr->exitScript, TCL_INDEX_NONE, NULL); + TpoolEval(interp, tpoolPtr->exitScript, TCL_INDEX_NONE, NULL); } tpoolPtr->numWorkers--; @@ -1325,7 +1325,7 @@ PushWork( ) { SpliceIn(rPtr, tpoolPtr->workHead); if (tpoolPtr->workTail == NULL) { - tpoolPtr->workTail = rPtr; + tpoolPtr->workTail = rPtr; } } @@ -1352,7 +1352,7 @@ PopWork( TpoolResult *rPtr = tpoolPtr->workTail; if (rPtr == NULL) { - return NULL; + return NULL; } tpoolPtr->workTail = rPtr->prevPtr; @@ -1387,7 +1387,7 @@ PushWaiter( SpliceIn(tsdPtr->waitPtr, tpoolPtr->waitHead); if (tpoolPtr->waitTail == NULL) { - tpoolPtr->waitTail = tsdPtr->waitPtr; + tpoolPtr->waitTail = tsdPtr->waitPtr; } } @@ -1414,7 +1414,7 @@ PopWaiter( TpoolWaiter *waitPtr = tpoolPtr->waitTail; if (waitPtr == NULL) { - return NULL; + return NULL; } tpoolPtr->waitTail = waitPtr->prevPtr; @@ -1480,12 +1480,12 @@ GetTpoolUnl ( ThreadPool *tpoolPtr = NULL; if (sscanf(tpoolName, TPOOL_HNDLPREFIX"%p", &tpool) != 1) { - return NULL; + return NULL; } for (tpoolPtr = tpoolList; tpoolPtr; tpoolPtr = tpoolPtr->nextPtr) { - if (tpoolPtr == tpool) { - break; - } + if (tpoolPtr == tpool) { + break; + } } return tpoolPtr; @@ -1520,29 +1520,29 @@ TpoolEval( ret = Tcl_EvalEx(interp, script, scriptLen, TCL_EVAL_GLOBAL); if (rPtr == NULL || rPtr->detached) { - return ret; + return ret; } rPtr->retcode = ret; if (ret == TCL_ERROR) { - errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY); - errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); - if (errorCode != NULL) { - rPtr->errorCode = (char *)ckalloc(1 + strlen(errorCode)); - strcpy(rPtr->errorCode, errorCode); - } - if (errorInfo != NULL) { - rPtr->errorInfo = (char *)ckalloc(1 + strlen(errorInfo)); - strcpy(rPtr->errorInfo, errorInfo); - } + errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY); + errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); + if (errorCode != NULL) { + rPtr->errorCode = (char *)ckalloc(1 + strlen(errorCode)); + strcpy(rPtr->errorCode, errorCode); + } + if (errorInfo != NULL) { + rPtr->errorInfo = (char *)ckalloc(1 + strlen(errorInfo)); + strcpy(rPtr->errorInfo, errorInfo); + } } result = Tcl_GetString(Tcl_GetObjResult(interp)); reslen = Tcl_GetObjResult(interp)->length; if (reslen == 0) { - rPtr->result = threadEmptyResult; + rPtr->result = threadEmptyResult; } else { - rPtr->result = strcpy((char *)ckalloc(1 + reslen), result); + rPtr->result = strcpy((char *)ckalloc(1 + reslen), result); } return ret; @@ -1569,33 +1569,33 @@ SetResult( TpoolResult *rPtr ) { if (rPtr->retcode == TCL_ERROR) { - if (rPtr->errorCode) { - if (interp) { - Tcl_SetObjErrorCode(interp,Tcl_NewStringObj(rPtr->errorCode, TCL_INDEX_NONE)); - } - ckfree(rPtr->errorCode); - rPtr->errorCode = NULL; - } - if (rPtr->errorInfo) { - if (interp) { - Tcl_AddErrorInfo(interp, rPtr->errorInfo); - } - ckfree(rPtr->errorInfo); - rPtr->errorInfo = NULL; - } + if (rPtr->errorCode) { + if (interp) { + Tcl_SetObjErrorCode(interp,Tcl_NewStringObj(rPtr->errorCode, TCL_INDEX_NONE)); + } + ckfree(rPtr->errorCode); + rPtr->errorCode = NULL; + } + if (rPtr->errorInfo) { + if (interp) { + Tcl_AddErrorInfo(interp, rPtr->errorInfo); + } + ckfree(rPtr->errorInfo); + rPtr->errorInfo = NULL; + } } if (rPtr->result) { - if (rPtr->result == threadEmptyResult) { - if (interp) { - Tcl_ResetResult(interp); - } - } else { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(rPtr->result, TCL_INDEX_NONE)); - } - ckfree(rPtr->result); - rPtr->result = NULL; - } + if (rPtr->result == threadEmptyResult) { + if (interp) { + Tcl_ResetResult(interp); + } + } else { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(rPtr->result, TCL_INDEX_NONE)); + } + ckfree(rPtr->result); + rPtr->result = NULL; + } } } @@ -1648,7 +1648,7 @@ TpoolRelease( Tcl_HashSearch search; if (tpoolPtr->refCount-- > 1) { - return tpoolPtr->refCount; + return tpoolPtr->refCount; } /* @@ -1665,14 +1665,14 @@ TpoolRelease( Tcl_MutexLock(&tpoolPtr->mutex); tpoolPtr->tearDown = 1; while (tpoolPtr->numWorkers > 0) { - PushWaiter(tpoolPtr); - Tcl_ConditionNotify(&tpoolPtr->cond); - Tcl_MutexUnlock(&tpoolPtr->mutex); - tsdPtr->stop = -1; - while(tsdPtr->stop == -1) { - Tcl_DoOneEvent(TCL_ALL_EVENTS); - } - Tcl_MutexLock(&tpoolPtr->mutex); + PushWaiter(tpoolPtr); + Tcl_ConditionNotify(&tpoolPtr->cond); + Tcl_MutexUnlock(&tpoolPtr->mutex); + tsdPtr->stop = -1; + while(tsdPtr->stop == -1) { + Tcl_DoOneEvent(TCL_ALL_EVENTS); + } + Tcl_MutexLock(&tpoolPtr->mutex); } Tcl_MutexUnlock(&tpoolPtr->mutex); @@ -1681,10 +1681,10 @@ TpoolRelease( */ if (tpoolPtr->initScript) { - ckfree(tpoolPtr->initScript); + ckfree(tpoolPtr->initScript); } if (tpoolPtr->exitScript) { - ckfree(tpoolPtr->exitScript); + ckfree(tpoolPtr->exitScript); } /* @@ -1693,21 +1693,21 @@ TpoolRelease( hPtr = Tcl_FirstHashEntry(&tpoolPtr->jobsDone, &search); while (hPtr != NULL) { - rPtr = (TpoolResult*)Tcl_GetHashValue(hPtr); - if (rPtr->result && rPtr->result != threadEmptyResult) { - ckfree(rPtr->result); - } - if (rPtr->retcode == TCL_ERROR) { - if (rPtr->errorInfo) { - ckfree(rPtr->errorInfo); - } - if (rPtr->errorCode) { - ckfree(rPtr->errorCode); - } - } - ckfree((char *)rPtr); - Tcl_DeleteHashEntry(hPtr); - hPtr = Tcl_NextHashEntry(&search); + rPtr = (TpoolResult*)Tcl_GetHashValue(hPtr); + if (rPtr->result && rPtr->result != threadEmptyResult) { + ckfree(rPtr->result); + } + if (rPtr->retcode == TCL_ERROR) { + if (rPtr->errorInfo) { + ckfree(rPtr->errorInfo); + } + if (rPtr->errorCode) { + ckfree(rPtr->errorCode); + } + } + ckfree((char *)rPtr); + Tcl_DeleteHashEntry(hPtr); + hPtr = Tcl_NextHashEntry(&search); } Tcl_DeleteHashTable(&tpoolPtr->jobsDone); @@ -1716,8 +1716,8 @@ TpoolRelease( */ for (rPtr = tpoolPtr->workHead; rPtr; rPtr = rPtr->nextPtr) { - ckfree(rPtr->script); - ckfree((char *)rPtr); + ckfree(rPtr->script); + ckfree((char *)rPtr); } Tcl_MutexFinalize(&tpoolPtr->mutex); Tcl_ConditionFinalize(&tpoolPtr->cond); @@ -1802,7 +1802,7 @@ SignalWaiter( waitPtr = PopWaiter(tpoolPtr); if (waitPtr == NULL) { - return; + return; } evPtr = (Tcl_Event *)ckalloc(sizeof(Tcl_Event)); @@ -1833,11 +1833,11 @@ InitWaiter () ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->waitPtr == NULL) { - tsdPtr->waitPtr = (TpoolWaiter *)ckalloc(sizeof(TpoolWaiter)); - tsdPtr->waitPtr->prevPtr = NULL; - tsdPtr->waitPtr->nextPtr = NULL; - tsdPtr->waitPtr->threadId = Tcl_GetCurrentThread(); - Tcl_CreateThreadExitHandler(ThrExitHandler, tsdPtr); + tsdPtr->waitPtr = (TpoolWaiter *)ckalloc(sizeof(TpoolWaiter)); + tsdPtr->waitPtr->prevPtr = NULL; + tsdPtr->waitPtr->nextPtr = NULL; + tsdPtr->waitPtr->threadId = Tcl_GetCurrentThread(); + Tcl_CreateThreadExitHandler(ThrExitHandler, tsdPtr); } } @@ -1891,7 +1891,7 @@ AppExitHandler( * Restart with head of list each time until empty. [Bug 1427570] */ for (tpoolPtr = tpoolList; tpoolPtr; tpoolPtr = tpoolList) { - TpoolRelease(tpoolPtr); + TpoolRelease(tpoolPtr); } Tcl_MutexUnlock(&listMutex); } @@ -1931,12 +1931,12 @@ TpoolInit ( TCL_CMD(interp, TPOOL_CMD_PREFIX"resume", TpoolResumeObjCmd); if (initialized == 0) { - Tcl_MutexLock(&listMutex); - if (initialized == 0) { - Tcl_CreateExitHandler(AppExitHandler, (void *)-1); - initialized = 1; - } - Tcl_MutexUnlock(&listMutex); + Tcl_MutexLock(&listMutex); + if (initialized == 0) { + Tcl_CreateExitHandler(AppExitHandler, (void *)-1); + initialized = 1; + } + Tcl_MutexUnlock(&listMutex); } return NULL; } diff --git a/generic/threadSpCmd.c b/generic/threadSpCmd.c index 757d169..6522abd 100644 --- a/generic/threadSpCmd.c +++ b/generic/threadSpCmd.c @@ -96,7 +96,7 @@ static int initOnce; /* Flag for initializing tables below */ static Tcl_Mutex initMutex; /* Controls initialization of primitives */ static SpBucket muxBuckets[NUMSPBUCKETS]; /* Maps mutex names/handles */ static SpBucket varBuckets[NUMSPBUCKETS]; /* Maps condition variable - * names/handles */ + * names/handles */ /* * Functions implementing Tcl commands @@ -188,10 +188,10 @@ ThreadMutexObjCmd( char type; SpMutex *mutexPtr; static const char *const cmdOpts[] = { - "create", "destroy", "lock", "unlock", NULL + "create", "destroy", "lock", "unlock", NULL }; enum options { - m_CREATE, m_DESTROY, m_LOCK, m_UNLOCK + m_CREATE, m_DESTROY, m_LOCK, m_UNLOCK }; /* @@ -204,12 +204,12 @@ ThreadMutexObjCmd( */ if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?args?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "option ?args?"); + return TCL_ERROR; } ret = Tcl_GetIndexFromObjStruct(interp, objv[1], cmdOpts, sizeof(char *), "option", 0, &opt); if (ret != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } /* @@ -217,48 +217,48 @@ ThreadMutexObjCmd( */ if (opt == (int)m_CREATE) { - Tcl_Obj *nameObj; - const char *arg; - - /* - * Parse out which type of mutex to create - */ - - if (objc == 2) { - type = EMUTEXID; - } else if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?-recursive?"); - return TCL_ERROR; - } else { - arg = Tcl_GetString(objv[2]); - if (OPT_CMP(arg, "-recursive")) { - type = RMUTEXID; - } else { - Tcl_WrongNumArgs(interp, 2, objv, "?-recursive?"); - return TCL_ERROR; - } - } - - /* - * Create the requested mutex - */ - - mutexPtr = (SpMutex*)ckalloc(sizeof(SpMutex)); - mutexPtr->type = type; - mutexPtr->bucket = NULL; - mutexPtr->hentry = NULL; - mutexPtr->lock = NULL; /* Will be auto-initialized */ - - /* - * Generate Tcl name for this mutex - */ - - nameObj = GetName(mutexPtr->type, (void*)mutexPtr); - mutexName = Tcl_GetString(nameObj); - nameLen = nameObj->length; - AddMutex(mutexName, nameLen, mutexPtr); - Tcl_SetObjResult(interp, nameObj); - return TCL_OK; + Tcl_Obj *nameObj; + const char *arg; + + /* + * Parse out which type of mutex to create + */ + + if (objc == 2) { + type = EMUTEXID; + } else if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?-recursive?"); + return TCL_ERROR; + } else { + arg = Tcl_GetString(objv[2]); + if (OPT_CMP(arg, "-recursive")) { + type = RMUTEXID; + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?-recursive?"); + return TCL_ERROR; + } + } + + /* + * Create the requested mutex + */ + + mutexPtr = (SpMutex*)ckalloc(sizeof(SpMutex)); + mutexPtr->type = type; + mutexPtr->bucket = NULL; + mutexPtr->hentry = NULL; + mutexPtr->lock = NULL; /* Will be auto-initialized */ + + /* + * Generate Tcl name for this mutex + */ + + nameObj = GetName(mutexPtr->type, (void*)mutexPtr); + mutexName = Tcl_GetString(nameObj); + nameLen = nameObj->length; + AddMutex(mutexName, nameLen, mutexPtr); + Tcl_SetObjResult(interp, nameObj); + return TCL_OK; } /* @@ -266,8 +266,8 @@ ThreadMutexObjCmd( */ if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "mutexHandle"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "mutexHandle"); + return TCL_ERROR; } mutexName = Tcl_GetString(objv[2]); @@ -278,19 +278,19 @@ ThreadMutexObjCmd( */ if (opt == (int)m_DESTROY) { - ret = RemoveMutex(mutexName, nameLen); - if (ret <= 0) { - if (ret == -1) { - notfound: - Tcl_AppendResult(interp, "no such mutex \"", mutexName, - "\"", (void *)NULL); - return TCL_ERROR; - } else { - Tcl_AppendResult(interp, "mutex is in use", (void *)NULL); - return TCL_ERROR; - } - } - return TCL_OK; + ret = RemoveMutex(mutexName, nameLen); + if (ret <= 0) { + if (ret == -1) { + notfound: + Tcl_AppendResult(interp, "no such mutex \"", mutexName, + "\"", (void *)NULL); + return TCL_ERROR; + } else { + Tcl_AppendResult(interp, "mutex is in use", (void *)NULL); + return TCL_ERROR; + } + } + return TCL_OK; } /* @@ -299,33 +299,33 @@ ThreadMutexObjCmd( mutexPtr = GetMutex(mutexName, nameLen); if (mutexPtr == NULL) { - goto notfound; + goto notfound; } if (!IsExclusive(mutexPtr) && !IsRecursive(mutexPtr)) { - PutMutex(mutexPtr); - Tcl_AppendResult(interp, "wrong mutex type, must be either" - " exclusive or recursive", (void *)NULL); - return TCL_ERROR; + PutMutex(mutexPtr); + Tcl_AppendResult(interp, "wrong mutex type, must be either" + " exclusive or recursive", (void *)NULL); + return TCL_ERROR; } switch ((enum options)opt) { case m_LOCK: - if (!SpMutexLock(mutexPtr)) { - PutMutex(mutexPtr); - Tcl_AppendResult(interp, "locking the same exclusive mutex " - "twice from the same thread", (void *)NULL); - return TCL_ERROR; - } - break; + if (!SpMutexLock(mutexPtr)) { + PutMutex(mutexPtr); + Tcl_AppendResult(interp, "locking the same exclusive mutex " + "twice from the same thread", (void *)NULL); + return TCL_ERROR; + } + break; case m_UNLOCK: - if (!SpMutexUnlock(mutexPtr)) { - PutMutex(mutexPtr); - Tcl_AppendResult(interp, "mutex is not locked", (void *)NULL); - return TCL_ERROR; - } - break; + if (!SpMutexUnlock(mutexPtr)) { + PutMutex(mutexPtr); + Tcl_AppendResult(interp, "mutex is not locked", (void *)NULL); + return TCL_ERROR; + } + break; default: - break; + break; } PutMutex(mutexPtr); @@ -365,10 +365,10 @@ ThreadRWMutexObjCmd( Sp_AnyMutex **lockPtr; static const char *const cmdOpts[] = { - "create", "destroy", "rlock", "wlock", "unlock", NULL + "create", "destroy", "rlock", "wlock", "unlock", NULL }; enum options { - w_CREATE, w_DESTROY, w_RLOCK, w_WLOCK, w_UNLOCK + w_CREATE, w_DESTROY, w_RLOCK, w_WLOCK, w_UNLOCK }; /* @@ -382,12 +382,12 @@ ThreadRWMutexObjCmd( */ if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?args?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "option ?args?"); + return TCL_ERROR; } ret = Tcl_GetIndexFromObjStruct(interp, objv[1], cmdOpts, sizeof(char *), "option", 0, &opt); if (ret != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } /* @@ -395,23 +395,23 @@ ThreadRWMutexObjCmd( */ if (opt == (int)w_CREATE) { - Tcl_Obj *nameObj; - if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "create"); - return TCL_ERROR; - } - mutexPtr = (SpMutex *)ckalloc(sizeof(SpMutex)); - mutexPtr->type = WMUTEXID; - mutexPtr->refcnt = 0; - mutexPtr->bucket = NULL; - mutexPtr->hentry = NULL; - mutexPtr->lock = NULL; /* Will be auto-initialized */ - - nameObj = GetName(mutexPtr->type, (void*)mutexPtr); - mutexName = Tcl_GetString(nameObj); - AddMutex(mutexName, nameObj->length, mutexPtr); - Tcl_SetObjResult(interp, nameObj); - return TCL_OK; + Tcl_Obj *nameObj; + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "create"); + return TCL_ERROR; + } + mutexPtr = (SpMutex *)ckalloc(sizeof(SpMutex)); + mutexPtr->type = WMUTEXID; + mutexPtr->refcnt = 0; + mutexPtr->bucket = NULL; + mutexPtr->hentry = NULL; + mutexPtr->lock = NULL; /* Will be auto-initialized */ + + nameObj = GetName(mutexPtr->type, (void*)mutexPtr); + mutexName = Tcl_GetString(nameObj); + AddMutex(mutexName, nameObj->length, mutexPtr); + Tcl_SetObjResult(interp, nameObj); + return TCL_OK; } /* @@ -419,8 +419,8 @@ ThreadRWMutexObjCmd( */ if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "mutexHandle"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "mutexHandle"); + return TCL_ERROR; } mutexName = Tcl_GetString(objv[2]); @@ -431,19 +431,19 @@ ThreadRWMutexObjCmd( */ if (opt == (int)w_DESTROY) { - ret = RemoveMutex(mutexName, nameLen); - if (ret <= 0) { - if (ret == -1) { - notfound: - Tcl_AppendResult(interp, "no such mutex \"", mutexName, - "\"", (void *)NULL); - return TCL_ERROR; - } else { - Tcl_AppendResult(interp, "mutex is in use", (void *)NULL); - return TCL_ERROR; - } - } - return TCL_OK; + ret = RemoveMutex(mutexName, nameLen); + if (ret <= 0) { + if (ret == -1) { + notfound: + Tcl_AppendResult(interp, "no such mutex \"", mutexName, + "\"", (void *)NULL); + return TCL_ERROR; + } else { + Tcl_AppendResult(interp, "mutex is in use", (void *)NULL); + return TCL_ERROR; + } + } + return TCL_OK; } /* @@ -452,12 +452,12 @@ ThreadRWMutexObjCmd( mutexPtr = GetMutex(mutexName, nameLen); if (mutexPtr == NULL) { - goto notfound; + goto notfound; } if (!IsReadWrite(mutexPtr)) { - PutMutex(mutexPtr); - Tcl_AppendResult(interp, "wrong mutex type, must be readwrite", (void *)NULL); - return TCL_ERROR; + PutMutex(mutexPtr); + Tcl_AppendResult(interp, "wrong mutex type, must be readwrite", (void *)NULL); + return TCL_ERROR; } lockPtr = &mutexPtr->lock; @@ -465,30 +465,30 @@ ThreadRWMutexObjCmd( switch ((enum options)opt) { case w_RLOCK: - if (!Sp_ReadWriteMutexRLock(rwPtr)) { - PutMutex(mutexPtr); - Tcl_AppendResult(interp, "read-locking already write-locked mutex ", - "from the same thread", (void *)NULL); - return TCL_ERROR; - } - break; + if (!Sp_ReadWriteMutexRLock(rwPtr)) { + PutMutex(mutexPtr); + Tcl_AppendResult(interp, "read-locking already write-locked mutex ", + "from the same thread", (void *)NULL); + return TCL_ERROR; + } + break; case w_WLOCK: - if (!Sp_ReadWriteMutexWLock(rwPtr)) { - PutMutex(mutexPtr); - Tcl_AppendResult(interp, "write-locking the same read-write " - "mutex twice from the same thread", (void *)NULL); - return TCL_ERROR; - } - break; + if (!Sp_ReadWriteMutexWLock(rwPtr)) { + PutMutex(mutexPtr); + Tcl_AppendResult(interp, "write-locking the same read-write " + "mutex twice from the same thread", (void *)NULL); + return TCL_ERROR; + } + break; case w_UNLOCK: - if (!Sp_ReadWriteMutexUnlock(rwPtr)) { - PutMutex(mutexPtr); - Tcl_AppendResult(interp, "mutex is not locked", (void *)NULL); - return TCL_ERROR; - } - break; + if (!Sp_ReadWriteMutexUnlock(rwPtr)) { + PutMutex(mutexPtr); + Tcl_AppendResult(interp, "mutex is not locked", (void *)NULL); + return TCL_ERROR; + } + break; default: - break; + break; } PutMutex(mutexPtr); @@ -528,10 +528,10 @@ ThreadCondObjCmd( SpCondv *condvPtr; static const char *const cmdOpts[] = { - "create", "destroy", "notify", "wait", NULL + "create", "destroy", "notify", "wait", NULL }; enum options { - c_CREATE, c_DESTROY, c_NOTIFY, c_WAIT + c_CREATE, c_DESTROY, c_NOTIFY, c_WAIT }; /* @@ -544,12 +544,12 @@ ThreadCondObjCmd( */ if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?args?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "option ?args?"); + return TCL_ERROR; } ret = Tcl_GetIndexFromObjStruct(interp, objv[1], cmdOpts, sizeof(char *), "option", 0, &opt); if (ret != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } /* @@ -557,23 +557,23 @@ ThreadCondObjCmd( */ if (opt == (int)c_CREATE) { - Tcl_Obj *nameObj; - if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "create"); - return TCL_ERROR; - } - condvPtr = (SpCondv *)ckalloc(sizeof(SpCondv)); - condvPtr->refcnt = 0; - condvPtr->bucket = NULL; - condvPtr->hentry = NULL; - condvPtr->mutex = NULL; - condvPtr->cond = NULL; /* Will be auto-initialized */ - - nameObj = GetName(CONDVID, (void*)condvPtr); - condvName = Tcl_GetString(nameObj); - AddCondv(condvName, nameObj->length, condvPtr); - Tcl_SetObjResult(interp, nameObj); - return TCL_OK; + Tcl_Obj *nameObj; + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "create"); + return TCL_ERROR; + } + condvPtr = (SpCondv *)ckalloc(sizeof(SpCondv)); + condvPtr->refcnt = 0; + condvPtr->bucket = NULL; + condvPtr->hentry = NULL; + condvPtr->mutex = NULL; + condvPtr->cond = NULL; /* Will be auto-initialized */ + + nameObj = GetName(CONDVID, (void*)condvPtr); + condvName = Tcl_GetString(nameObj); + AddCondv(condvName, nameObj->length, condvPtr); + Tcl_SetObjResult(interp, nameObj); + return TCL_OK; } /* @@ -581,8 +581,8 @@ ThreadCondObjCmd( */ if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "condHandle ?args?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "condHandle ?args?"); + return TCL_ERROR; } condvName = Tcl_GetString(objv[2]); @@ -593,19 +593,19 @@ ThreadCondObjCmd( */ if (opt == (int)c_DESTROY) { - ret = RemoveCondv(condvName, nameLen); - if (ret <= 0) { - if (ret == -1) { - notfound: - Tcl_AppendResult(interp, "no such condition variable \"", - condvName, "\"", (void *)NULL); - return TCL_ERROR; - } else { - Tcl_AppendResult(interp, "condition variable is in use", (void *)NULL); - return TCL_ERROR; - } - } - return TCL_OK; + ret = RemoveCondv(condvName, nameLen); + if (ret <= 0) { + if (ret == -1) { + notfound: + Tcl_AppendResult(interp, "no such condition variable \"", + condvName, "\"", (void *)NULL); + return TCL_ERROR; + } else { + Tcl_AppendResult(interp, "condition variable is in use", (void *)NULL); + return TCL_ERROR; + } + } + return TCL_OK; } /* @@ -614,51 +614,51 @@ ThreadCondObjCmd( condvPtr = GetCondv(condvName, nameLen); if (condvPtr == NULL) { - goto notfound; + goto notfound; } switch ((enum options)opt) { case c_WAIT: - /* - * May improve the Tcl_ConditionWait() to report timeouts so we can - * inform script programmer about this interesting fact. I think - * there is still a place for something like Tcl_ConditionWaitEx() - * or similar in the core. - */ - - if (objc < 4 || objc > 5) { - PutCondv(condvPtr); - Tcl_WrongNumArgs(interp, 2, objv, "condHandle mutexHandle ?timeout?"); - return TCL_ERROR; - } - if (objc == 5) { - if (Tcl_GetIntFromObj(interp, objv[4], &timeMsec) != TCL_OK) { - PutCondv(condvPtr); - return TCL_ERROR; - } - } - mutexName = Tcl_GetString(objv[3]); - mutexPtr = GetMutex(mutexName, objv[3]->length); - if (mutexPtr == NULL) { - PutCondv(condvPtr); - Tcl_AppendResult(interp, "no such mutex \"",mutexName,"\"", (void *)NULL); - return TCL_ERROR; - } - if (!IsExclusive(mutexPtr) - || SpCondvWait(condvPtr, mutexPtr, timeMsec) == 0) { - PutCondv(condvPtr); - PutMutex(mutexPtr); - Tcl_AppendResult(interp, "mutex not locked or wrong type", (void *)NULL); - return TCL_ERROR; - } - PutMutex(mutexPtr); - break; + /* + * May improve the Tcl_ConditionWait() to report timeouts so we can + * inform script programmer about this interesting fact. I think + * there is still a place for something like Tcl_ConditionWaitEx() + * or similar in the core. + */ + + if (objc < 4 || objc > 5) { + PutCondv(condvPtr); + Tcl_WrongNumArgs(interp, 2, objv, "condHandle mutexHandle ?timeout?"); + return TCL_ERROR; + } + if (objc == 5) { + if (Tcl_GetIntFromObj(interp, objv[4], &timeMsec) != TCL_OK) { + PutCondv(condvPtr); + return TCL_ERROR; + } + } + mutexName = Tcl_GetString(objv[3]); + mutexPtr = GetMutex(mutexName, objv[3]->length); + if (mutexPtr == NULL) { + PutCondv(condvPtr); + Tcl_AppendResult(interp, "no such mutex \"",mutexName,"\"", (void *)NULL); + return TCL_ERROR; + } + if (!IsExclusive(mutexPtr) + || SpCondvWait(condvPtr, mutexPtr, timeMsec) == 0) { + PutCondv(condvPtr); + PutMutex(mutexPtr); + Tcl_AppendResult(interp, "mutex not locked or wrong type", (void *)NULL); + return TCL_ERROR; + } + PutMutex(mutexPtr); + break; case c_NOTIFY: - SpCondvNotify(condvPtr); - break; + SpCondvNotify(condvPtr); + break; default: - break; + break; } PutCondv(condvPtr); @@ -703,9 +703,9 @@ ThreadEvalObjCmd( if (objc < 2) { syntax: - Tcl_WrongNumArgs(interp, 1, objv, - "?-lock ? arg ?arg...?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, + "?-lock ? arg ?arg...?"); + return TCL_ERROR; } /* @@ -720,31 +720,31 @@ ThreadEvalObjCmd( */ if (OPT_CMP(Tcl_GetString(objv[1]), "-lock") == 0) { - internal = 1; - optx = 1; - Sp_RecursiveMutexLock(&evalMutex); + internal = 1; + optx = 1; + Sp_RecursiveMutexLock(&evalMutex); } else { - internal = 0; - optx = 3; - if ((objc - optx) < 1) { - goto syntax; - } - mutexName = Tcl_GetString(objv[2]); - mutexPtr = GetMutex(mutexName, objv[2]->length); - if (mutexPtr == NULL) { - Tcl_AppendResult(interp, "no such mutex \"",mutexName,"\"", (void *)NULL); - return TCL_ERROR; - } - if (IsReadWrite(mutexPtr)) { - Tcl_AppendResult(interp, "wrong mutex type, must be exclusive " - "or recursive", (void *)NULL); - return TCL_ERROR; - } - if (!SpMutexLock(mutexPtr)) { - Tcl_AppendResult(interp, "locking the same exclusive mutex " - "twice from the same thread", (void *)NULL); - return TCL_ERROR; - } + internal = 0; + optx = 3; + if ((objc - optx) < 1) { + goto syntax; + } + mutexName = Tcl_GetString(objv[2]); + mutexPtr = GetMutex(mutexName, objv[2]->length); + if (mutexPtr == NULL) { + Tcl_AppendResult(interp, "no such mutex \"",mutexName,"\"", (void *)NULL); + return TCL_ERROR; + } + if (IsReadWrite(mutexPtr)) { + Tcl_AppendResult(interp, "wrong mutex type, must be exclusive " + "or recursive", (void *)NULL); + return TCL_ERROR; + } + if (!SpMutexLock(mutexPtr)) { + Tcl_AppendResult(interp, "locking the same exclusive mutex " + "twice from the same thread", (void *)NULL); + return TCL_ERROR; + } } objc -= optx; @@ -757,9 +757,9 @@ ThreadEvalObjCmd( */ if (objc == 1) { - scriptObj = Tcl_DuplicateObj(objv[optx]); + scriptObj = Tcl_DuplicateObj(objv[optx]); } else { - scriptObj = Tcl_ConcatObj(objc, objv + optx); + scriptObj = Tcl_ConcatObj(objc, objv + optx); } Tcl_IncrRefCount(scriptObj); @@ -767,11 +767,11 @@ ThreadEvalObjCmd( Tcl_DecrRefCount(scriptObj); if (ret == TCL_ERROR) { - char msg[32 + TCL_INTEGER_SPACE]; - /* Next line generates a Deprecation warning when compiled with Tcl 8.6. - * See Tcl bug #3562640 */ - snprintf(msg, sizeof(msg), "\n (\"eval\" body line %d)", Tcl_GetErrorLine(interp)); - Tcl_AddErrorInfo(interp, msg); + char msg[32 + TCL_INTEGER_SPACE]; + /* Next line generates a Deprecation warning when compiled with Tcl 8.6. + * See Tcl bug #3562640 */ + snprintf(msg, sizeof(msg), "\n (\"eval\" body line %d)", Tcl_GetErrorLine(interp)); + Tcl_AddErrorInfo(interp, msg); } /* @@ -779,9 +779,9 @@ ThreadEvalObjCmd( */ if (internal) { - Sp_RecursiveMutexUnlock(&evalMutex); + Sp_RecursiveMutexUnlock(&evalMutex); } else { - SpMutexUnlock(mutexPtr); + SpMutexUnlock(mutexPtr); } return ret; @@ -877,8 +877,8 @@ GetAnyItem(int type, const char *name, size_t len) Tcl_MutexLock(&bucketPtr->lock); hashEntryPtr = Tcl_FindHashEntry(&bucketPtr->handles, name); if (hashEntryPtr != NULL) { - itemPtr = (SpItem*)Tcl_GetHashValue(hashEntryPtr); - itemPtr->refcnt++; + itemPtr = (SpItem*)Tcl_GetHashValue(hashEntryPtr); + itemPtr->refcnt++; } Tcl_MutexUnlock(&bucketPtr->lock); @@ -972,13 +972,13 @@ RemoveAnyItem(int type, const char *name, size_t len) Tcl_MutexLock(&bucketPtr->lock); hashEntryPtr = Tcl_FindHashEntry(&bucketPtr->handles, name); if (hashEntryPtr == NULL) { - Tcl_MutexUnlock(&bucketPtr->lock); - return NULL; + Tcl_MutexUnlock(&bucketPtr->lock); + return NULL; } itemPtr = (SpItem*)Tcl_GetHashValue(hashEntryPtr); Tcl_DeleteHashEntry(hashEntryPtr); while (itemPtr->refcnt > 0) { - Tcl_ConditionWait(&bucketPtr->cond, &bucketPtr->lock, NULL); + Tcl_ConditionWait(&bucketPtr->cond, &bucketPtr->lock, NULL); } Tcl_MutexUnlock(&bucketPtr->lock); @@ -1008,11 +1008,11 @@ RemoveMutex(const char *name, size_t len) { SpMutex *mutexPtr = GetMutex(name, len); if (mutexPtr == NULL) { - return -1; + return -1; } if (!SpMutexFinalize(mutexPtr)) { - PutMutex(mutexPtr); - return 0; + PutMutex(mutexPtr); + return 0; } PutMutex(mutexPtr); RemoveAnyItem(SP_MUTEX, name, len); @@ -1044,11 +1044,11 @@ RemoveCondv(const char *name, size_t len) { SpCondv *condvPtr = GetCondv(name, len); if (condvPtr == NULL) { - return -1; + return -1; } if (!SpCondvFinalize(condvPtr)) { - PutCondv(condvPtr); - return 0; + PutCondv(condvPtr); + return 0; } PutCondv(condvPtr); RemoveAnyItem(SP_CONDV, name, len); @@ -1081,22 +1081,22 @@ SpInit ( SpBucket *bucketPtr; if (!initOnce) { - Tcl_MutexLock(&initMutex); - if (!initOnce) { - int ii; - for (ii = 0; ii < NUMSPBUCKETS; ii++) { - bucketPtr = &muxBuckets[ii]; - memset(bucketPtr, 0, sizeof(SpBucket)); - Tcl_InitHashTable(&bucketPtr->handles, TCL_STRING_KEYS); - } - for (ii = 0; ii < NUMSPBUCKETS; ii++) { - bucketPtr = &varBuckets[ii]; - memset(bucketPtr, 0, sizeof(SpBucket)); - Tcl_InitHashTable(&bucketPtr->handles, TCL_STRING_KEYS); - } - initOnce = 1; - } - Tcl_MutexUnlock(&initMutex); + Tcl_MutexLock(&initMutex); + if (!initOnce) { + int ii; + for (ii = 0; ii < NUMSPBUCKETS; ii++) { + bucketPtr = &muxBuckets[ii]; + memset(bucketPtr, 0, sizeof(SpBucket)); + Tcl_InitHashTable(&bucketPtr->handles, TCL_STRING_KEYS); + } + for (ii = 0; ii < NUMSPBUCKETS; ii++) { + bucketPtr = &varBuckets[ii]; + memset(bucketPtr, 0, sizeof(SpBucket)); + Tcl_InitHashTable(&bucketPtr->handles, TCL_STRING_KEYS); + } + initOnce = 1; + } + Tcl_MutexUnlock(&initMutex); } TCL_CMD(interp, THREAD_CMD_PREFIX"::mutex", ThreadMutexObjCmd); @@ -1131,11 +1131,11 @@ SpMutexLock(SpMutex *mutexPtr) switch (mutexPtr->type) { case EMUTEXID: - return Sp_ExclusiveMutexLock((Sp_ExclusiveMutex*)lockPtr); - break; + return Sp_ExclusiveMutexLock((Sp_ExclusiveMutex*)lockPtr); + break; case RMUTEXID: - return Sp_RecursiveMutexLock((Sp_RecursiveMutex*)lockPtr); - break; + return Sp_RecursiveMutexLock((Sp_RecursiveMutex*)lockPtr); + break; } return 0; @@ -1165,11 +1165,11 @@ SpMutexUnlock(SpMutex *mutexPtr) switch (mutexPtr->type) { case EMUTEXID: - return Sp_ExclusiveMutexUnlock((Sp_ExclusiveMutex*)lockPtr); - break; + return Sp_ExclusiveMutexUnlock((Sp_ExclusiveMutex*)lockPtr); + break; case RMUTEXID: - return Sp_RecursiveMutexUnlock((Sp_RecursiveMutex*)lockPtr); - break; + return Sp_RecursiveMutexUnlock((Sp_RecursiveMutex*)lockPtr); + break; } return 0; @@ -1199,7 +1199,7 @@ SpMutexFinalize(SpMutex *mutexPtr) Sp_AnyMutex **lockPtr = &mutexPtr->lock; if (AnyMutexIsLocked((Sp_AnyMutex*)mutexPtr->lock, NULL)) { - return 0; + return 0; } /* @@ -1209,16 +1209,16 @@ SpMutexFinalize(SpMutex *mutexPtr) switch (mutexPtr->type) { case EMUTEXID: - Sp_ExclusiveMutexFinalize((Sp_ExclusiveMutex*)lockPtr); - break; + Sp_ExclusiveMutexFinalize((Sp_ExclusiveMutex*)lockPtr); + break; case RMUTEXID: - Sp_RecursiveMutexFinalize((Sp_RecursiveMutex*)lockPtr); - break; + Sp_RecursiveMutexFinalize((Sp_RecursiveMutex*)lockPtr); + break; case WMUTEXID: - Sp_ReadWriteMutexFinalize((Sp_ReadWriteMutex*)lockPtr); - break; + Sp_ReadWriteMutexFinalize((Sp_ReadWriteMutex*)lockPtr); + break; default: - break; + break; } return 1; @@ -1250,12 +1250,12 @@ SpCondvWait(SpCondv *condvPtr, SpMutex *mutexPtr, int msec) Tcl_ThreadId threadId = Tcl_GetCurrentThread(); if (msec > 0) { - wt = &waitTime; - wt->sec = (msec/1000); - wt->usec = (msec%1000) * 1000; + wt = &waitTime; + wt->sec = (msec/1000); + wt->usec = (msec%1000) * 1000; } if (!AnyMutexIsLocked((Sp_AnyMutex*)mutexPtr->lock, threadId)) { - return 0; /* Mutex not locked by the current thread */ + return 0; /* Mutex not locked by the current thread */ } /* @@ -1299,7 +1299,7 @@ static void SpCondvNotify(SpCondv *condvPtr) { if (condvPtr->cond) { - Tcl_ConditionNotify(&condvPtr->cond); + Tcl_ConditionNotify(&condvPtr->cond); } } @@ -1324,11 +1324,11 @@ static int SpCondvFinalize(SpCondv *condvPtr) { if (condvPtr->mutex != NULL) { - return 0; /* Somebody is waiting on the variable */ + return 0; /* Somebody is waiting on the variable */ } if (condvPtr->cond) { - Tcl_ConditionFinalize(&condvPtr->cond); + Tcl_ConditionFinalize(&condvPtr->cond); } return 1; @@ -1362,13 +1362,13 @@ Sp_ExclusiveMutexLock(Sp_ExclusiveMutex *muxPtr) */ if (*muxPtr == NULL) { - Tcl_MutexLock(&initMutex); - if (*muxPtr == NULL) { - *muxPtr = (Sp_ExclusiveMutex_ *) - ckalloc(sizeof(Sp_ExclusiveMutex_)); - memset(*muxPtr, 0, sizeof(Sp_ExclusiveMutex_)); - } - Tcl_MutexUnlock(&initMutex); + Tcl_MutexLock(&initMutex); + if (*muxPtr == NULL) { + *muxPtr = (Sp_ExclusiveMutex_ *) + ckalloc(sizeof(Sp_ExclusiveMutex_)); + memset(*muxPtr, 0, sizeof(Sp_ExclusiveMutex_)); + } + Tcl_MutexUnlock(&initMutex); } /* @@ -1378,8 +1378,8 @@ Sp_ExclusiveMutexLock(Sp_ExclusiveMutex *muxPtr) emPtr = *(Sp_ExclusiveMutex_**)muxPtr; Tcl_MutexLock(&emPtr->lock); if (emPtr->lockcount && emPtr->owner == thisThread) { - Tcl_MutexUnlock(&emPtr->lock); - return 0; /* Already locked by the same thread */ + Tcl_MutexUnlock(&emPtr->lock); + return 0; /* Already locked by the same thread */ } Tcl_MutexUnlock(&emPtr->lock); @@ -1445,15 +1445,15 @@ Sp_ExclusiveMutexUnlock(Sp_ExclusiveMutex *muxPtr) Sp_ExclusiveMutex_ *emPtr; if (*muxPtr == (Sp_ExclusiveMutex_*)0) { - return 0; /* Never locked before */ + return 0; /* Never locked before */ } emPtr = *(Sp_ExclusiveMutex_**)muxPtr; Tcl_MutexLock(&emPtr->lock); if (emPtr->lockcount == 0) { - Tcl_MutexUnlock(&emPtr->lock); - return 0; /* Not locked */ + Tcl_MutexUnlock(&emPtr->lock); + return 0; /* Not locked */ } emPtr->owner = NULL; emPtr->lockcount = 0; @@ -1490,14 +1490,14 @@ void Sp_ExclusiveMutexFinalize(Sp_ExclusiveMutex *muxPtr) { if (*muxPtr != (Sp_ExclusiveMutex_*)0) { - Sp_ExclusiveMutex_ *emPtr = *(Sp_ExclusiveMutex_**)muxPtr; - if (emPtr->lock) { - Tcl_MutexFinalize(&emPtr->lock); - } - if (emPtr->mutex) { - Tcl_MutexFinalize(&emPtr->mutex); - } - ckfree((char *)*muxPtr); + Sp_ExclusiveMutex_ *emPtr = *(Sp_ExclusiveMutex_**)muxPtr; + if (emPtr->lock) { + Tcl_MutexFinalize(&emPtr->lock); + } + if (emPtr->mutex) { + Tcl_MutexFinalize(&emPtr->mutex); + } + ckfree((char *)*muxPtr); } } @@ -1528,44 +1528,44 @@ Sp_RecursiveMutexLock(Sp_RecursiveMutex *muxPtr) */ if (*muxPtr == (Sp_RecursiveMutex_*)0) { - Tcl_MutexLock(&initMutex); - if (*muxPtr == (Sp_RecursiveMutex_*)0) { - *muxPtr = (Sp_RecursiveMutex_ *) - ckalloc(sizeof(Sp_RecursiveMutex_)); - memset(*muxPtr, 0, sizeof(Sp_RecursiveMutex_)); - } - Tcl_MutexUnlock(&initMutex); + Tcl_MutexLock(&initMutex); + if (*muxPtr == (Sp_RecursiveMutex_*)0) { + *muxPtr = (Sp_RecursiveMutex_ *) + ckalloc(sizeof(Sp_RecursiveMutex_)); + memset(*muxPtr, 0, sizeof(Sp_RecursiveMutex_)); + } + Tcl_MutexUnlock(&initMutex); } rmPtr = *(Sp_RecursiveMutex_**)muxPtr; Tcl_MutexLock(&rmPtr->lock); if (rmPtr->owner == thisThread) { - /* - * We are already holding the mutex - * so just count one more lock. - */ - rmPtr->lockcount++; + /* + * We are already holding the mutex + * so just count one more lock. + */ + rmPtr->lockcount++; } else { - if (rmPtr->owner == NULL) { - /* - * Nobody holds the mutex, we do now. - */ - rmPtr->owner = thisThread; - rmPtr->lockcount = 1; - } else { - /* - * Somebody else holds the mutex; wait. - */ - while (1) { - Tcl_ConditionWait(&rmPtr->cond, &rmPtr->lock, NULL); - if (rmPtr->owner == NULL) { - rmPtr->owner = thisThread; - rmPtr->lockcount = 1; - break; - } - } - } + if (rmPtr->owner == NULL) { + /* + * Nobody holds the mutex, we do now. + */ + rmPtr->owner = thisThread; + rmPtr->lockcount = 1; + } else { + /* + * Somebody else holds the mutex; wait. + */ + while (1) { + Tcl_ConditionWait(&rmPtr->cond, &rmPtr->lock, NULL); + if (rmPtr->owner == NULL) { + rmPtr->owner = thisThread; + rmPtr->lockcount = 1; + break; + } + } + } } Tcl_MutexUnlock(&rmPtr->lock); @@ -1619,21 +1619,21 @@ Sp_RecursiveMutexUnlock(Sp_RecursiveMutex *muxPtr) Sp_RecursiveMutex_ *rmPtr; if (*muxPtr == (Sp_RecursiveMutex_*)0) { - return 0; /* Never locked before */ + return 0; /* Never locked before */ } rmPtr = *(Sp_RecursiveMutex_**)muxPtr; Tcl_MutexLock(&rmPtr->lock); if (rmPtr->lockcount == 0) { - Tcl_MutexUnlock(&rmPtr->lock); - return 0; /* Not locked now */ + Tcl_MutexUnlock(&rmPtr->lock); + return 0; /* Not locked now */ } if (--rmPtr->lockcount <= 0) { - rmPtr->lockcount = 0; - rmPtr->owner = NULL; - if (rmPtr->cond) { - Tcl_ConditionNotify(&rmPtr->cond); - } + rmPtr->lockcount = 0; + rmPtr->owner = NULL; + if (rmPtr->cond) { + Tcl_ConditionNotify(&rmPtr->cond); + } } Tcl_MutexUnlock(&rmPtr->lock); @@ -1661,14 +1661,14 @@ void Sp_RecursiveMutexFinalize(Sp_RecursiveMutex *muxPtr) { if (*muxPtr != NULL) { - Sp_RecursiveMutex_ *rmPtr = *(Sp_RecursiveMutex_**)muxPtr; - if (rmPtr->lock) { - Tcl_MutexFinalize(&rmPtr->lock); - } - if (rmPtr->cond) { - Tcl_ConditionFinalize(&rmPtr->cond); - } - ckfree((char *)*muxPtr); + Sp_RecursiveMutex_ *rmPtr = *(Sp_RecursiveMutex_**)muxPtr; + if (rmPtr->lock) { + Tcl_MutexFinalize(&rmPtr->lock); + } + if (rmPtr->cond) { + Tcl_ConditionFinalize(&rmPtr->cond); + } + ckfree((char *)*muxPtr); } } @@ -1700,25 +1700,25 @@ Sp_ReadWriteMutexRLock(Sp_ReadWriteMutex *muxPtr) */ if (*muxPtr == (Sp_ReadWriteMutex_*)0) { - Tcl_MutexLock(&initMutex); - if (*muxPtr == (Sp_ReadWriteMutex_*)0) { - *muxPtr = (Sp_ReadWriteMutex_ *) - ckalloc(sizeof(Sp_ReadWriteMutex_)); - memset(*muxPtr, 0, sizeof(Sp_ReadWriteMutex_)); - } - Tcl_MutexUnlock(&initMutex); + Tcl_MutexLock(&initMutex); + if (*muxPtr == (Sp_ReadWriteMutex_*)0) { + *muxPtr = (Sp_ReadWriteMutex_ *) + ckalloc(sizeof(Sp_ReadWriteMutex_)); + memset(*muxPtr, 0, sizeof(Sp_ReadWriteMutex_)); + } + Tcl_MutexUnlock(&initMutex); } rwPtr = *(Sp_ReadWriteMutex_**)muxPtr; Tcl_MutexLock(&rwPtr->lock); if (rwPtr->lockcount == -1 && rwPtr->owner == thisThread) { - Tcl_MutexUnlock(&rwPtr->lock); - return 0; /* We already hold the write lock */ + Tcl_MutexUnlock(&rwPtr->lock); + return 0; /* We already hold the write lock */ } while (rwPtr->lockcount < 0) { - rwPtr->numrd++; - Tcl_ConditionWait(&rwPtr->rcond, &rwPtr->lock, NULL); - rwPtr->numrd--; + rwPtr->numrd++; + Tcl_ConditionWait(&rwPtr->rcond, &rwPtr->lock, NULL); + rwPtr->numrd--; } rwPtr->lockcount++; rwPtr->owner = NULL; /* Many threads can read-lock */ @@ -1755,25 +1755,25 @@ Sp_ReadWriteMutexWLock(Sp_ReadWriteMutex *muxPtr) */ if (*muxPtr == (Sp_ReadWriteMutex_*)0) { - Tcl_MutexLock(&initMutex); - if (*muxPtr == (Sp_ReadWriteMutex_*)0) { - *muxPtr = (Sp_ReadWriteMutex_ *) - ckalloc(sizeof(Sp_ReadWriteMutex_)); - memset(*muxPtr, 0, sizeof(Sp_ReadWriteMutex_)); - } - Tcl_MutexUnlock(&initMutex); + Tcl_MutexLock(&initMutex); + if (*muxPtr == (Sp_ReadWriteMutex_*)0) { + *muxPtr = (Sp_ReadWriteMutex_ *) + ckalloc(sizeof(Sp_ReadWriteMutex_)); + memset(*muxPtr, 0, sizeof(Sp_ReadWriteMutex_)); + } + Tcl_MutexUnlock(&initMutex); } rwPtr = *(Sp_ReadWriteMutex_**)muxPtr; Tcl_MutexLock(&rwPtr->lock); if (rwPtr->owner == thisThread && rwPtr->lockcount == -1) { - Tcl_MutexUnlock(&rwPtr->lock); - return 0; /* The same thread attempts to write-lock again */ + Tcl_MutexUnlock(&rwPtr->lock); + return 0; /* The same thread attempts to write-lock again */ } while (rwPtr->lockcount != 0) { - rwPtr->numwr++; - Tcl_ConditionWait(&rwPtr->wcond, &rwPtr->lock, NULL); - rwPtr->numwr--; + rwPtr->numwr++; + Tcl_ConditionWait(&rwPtr->wcond, &rwPtr->lock, NULL); + rwPtr->numwr--; } rwPtr->lockcount = -1; /* This designates the sole writer */ rwPtr->owner = thisThread; /* which is our current thread */ @@ -1826,23 +1826,23 @@ Sp_ReadWriteMutexUnlock(Sp_ReadWriteMutex *muxPtr) Sp_ReadWriteMutex_ *rwPtr; if (*muxPtr == (Sp_ReadWriteMutex_*)0) { - return 0; /* Never locked before */ + return 0; /* Never locked before */ } rwPtr = *(Sp_ReadWriteMutex_**)muxPtr; Tcl_MutexLock(&rwPtr->lock); if (rwPtr->lockcount == 0) { - Tcl_MutexUnlock(&rwPtr->lock); - return 0; /* Not locked now */ + Tcl_MutexUnlock(&rwPtr->lock); + return 0; /* Not locked now */ } if (--rwPtr->lockcount <= 0) { - rwPtr->lockcount = 0; - rwPtr->owner = NULL; + rwPtr->lockcount = 0; + rwPtr->owner = NULL; } if (rwPtr->numwr) { - Tcl_ConditionNotify(&rwPtr->wcond); + Tcl_ConditionNotify(&rwPtr->wcond); } else if (rwPtr->numrd) { - Tcl_ConditionNotify(&rwPtr->rcond); + Tcl_ConditionNotify(&rwPtr->rcond); } Tcl_MutexUnlock(&rwPtr->lock); @@ -1871,17 +1871,17 @@ void Sp_ReadWriteMutexFinalize(Sp_ReadWriteMutex *muxPtr) { if (*muxPtr != (Sp_ReadWriteMutex_*)0) { - Sp_ReadWriteMutex_ *rwPtr = *(Sp_ReadWriteMutex_**)muxPtr; - if (rwPtr->lock) { - Tcl_MutexFinalize(&rwPtr->lock); - } - if (rwPtr->rcond) { - Tcl_ConditionFinalize(&rwPtr->rcond); - } - if (rwPtr->wcond) { - Tcl_ConditionFinalize(&rwPtr->wcond); - } - ckfree((char *)*muxPtr); + Sp_ReadWriteMutex_ *rwPtr = *(Sp_ReadWriteMutex_**)muxPtr; + if (rwPtr->lock) { + Tcl_MutexFinalize(&rwPtr->lock); + } + if (rwPtr->rcond) { + Tcl_ConditionFinalize(&rwPtr->rcond); + } + if (rwPtr->wcond) { + Tcl_ConditionFinalize(&rwPtr->wcond); + } + ckfree((char *)*muxPtr); } } @@ -1909,12 +1909,12 @@ AnyMutexIsLocked(Sp_AnyMutex *mPtr, Tcl_ThreadId threadId) int locked = 0; if (mPtr != NULL) { - Tcl_MutexLock(&mPtr->lock); - locked = mPtr->lockcount != 0; - if (locked && threadId != NULL) { - locked = mPtr->owner == threadId; - } - Tcl_MutexUnlock(&mPtr->lock); + Tcl_MutexLock(&mPtr->lock); + locked = mPtr->lockcount != 0; + if (locked && threadId != NULL) { + locked = mPtr->owner == threadId; + } + Tcl_MutexUnlock(&mPtr->lock); } return locked; diff --git a/generic/threadSvCmd.c b/generic/threadSvCmd.c index b307cb1..50043bf 100644 --- a/generic/threadSvCmd.c +++ b/generic/threadSvCmd.c @@ -130,7 +130,7 @@ static void SvFinalize(void *); static PsStore* GetPsStore(const char *handle); static int SvObjDispatchObjCmd(void *arg, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* *----------------------------------------------------------------------------- @@ -150,10 +150,10 @@ static int SvObjDispatchObjCmd(void *arg, void Sv_RegisterCommand( - const char *cmdName, /* Name of command to register */ - Tcl_ObjCmdProc *objProc, /* Object-based command procedure */ - Tcl_CmdDeleteProc *delProc, /* Command delete procedure */ - int aolSpecial) + const char *cmdName, /* Name of command to register */ + Tcl_ObjCmdProc *objProc, /* Object-based command procedure */ + Tcl_CmdDeleteProc *delProc, /* Command delete procedure */ + int aolSpecial) { size_t len = strlen(cmdName) + strlen(TSV_CMD_PREFIX) + 1; size_t len2 = strlen(cmdName) + strlen(TSV_CMD2_PREFIX) + 1; @@ -188,11 +188,11 @@ Sv_RegisterCommand( Tcl_MutexLock(&svMutex); if (svCmdInfo == NULL) { - svCmdInfo = newCmd; - newCmd->nextPtr = NULL; + svCmdInfo = newCmd; + newCmd->nextPtr = NULL; } else { - newCmd->nextPtr = svCmdInfo; - svCmdInfo = newCmd; + newCmd->nextPtr = svCmdInfo; + svCmdInfo = newCmd; } Tcl_MutexUnlock(&svMutex); @@ -221,8 +221,8 @@ Sv_RegisterCommand( void Sv_RegisterObjType( - const Tcl_ObjType *typePtr, /* Type of object to register */ - Tcl_DupInternalRepProc *dupProc) /* Custom object duplicator */ + const Tcl_ObjType *typePtr, /* Type of object to register */ + Tcl_DupInternalRepProc *dupProc) /* Custom object duplicator */ { RegType *newType = (RegType *)ckalloc(sizeof(RegType)); @@ -273,11 +273,11 @@ Sv_RegisterPsStore(const PsStore *psStorePtr) Tcl_MutexLock(&svMutex); if (psStore == NULL) { - psStore = psPtr; - psStore->nextPtr = NULL; + psStore = psPtr; + psStore->nextPtr = NULL; } else { - psPtr->nextPtr = psStore; - psStore = psPtr; + psPtr->nextPtr = psStore; + psStore = psPtr; } Tcl_MutexUnlock(&svMutex); } @@ -305,55 +305,55 @@ Sv_RegisterPsStore(const PsStore *psStorePtr) int Sv_GetContainer( - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments */ - Tcl_Obj *const objv[], /* Argument objects. */ - Container **retObj, /* OUT: shared object container */ - int *offset, /* Shift in argument list */ - int flags) /* Options for locking shared array */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments */ + Tcl_Obj *const objv[], /* Argument objects. */ + Container **retObj, /* OUT: shared object container */ + int *offset, /* Shift in argument list */ + int flags) /* Options for locking shared array */ { const char *array, *key; if (*retObj == NULL) { - Array *arrayPtr = NULL; - - /* - * Parse mandatory arguments: array key - */ - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "array key ?args?"); - return TCL_ERROR; - } - - array = Tcl_GetString(objv[1]); - key = Tcl_GetString(objv[2]); - - *offset = 3; /* Consumed three arguments: cmd, array, key */ - - /* - * Lock the shared array and locate the shared object - */ - - arrayPtr = LockArray(interp, array, flags); - if (arrayPtr == NULL) { - return TCL_BREAK; - } - *retObj = AcquireContainer(arrayPtr, Tcl_GetString(objv[2]), flags); - if (*retObj == NULL) { - UnlockArray(arrayPtr); - Tcl_AppendResult(interp, "no key ", array, "(", key, ")", (void *)NULL); - return TCL_BREAK; - } + Array *arrayPtr = NULL; + + /* + * Parse mandatory arguments: array key + */ + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "array key ?args?"); + return TCL_ERROR; + } + + array = Tcl_GetString(objv[1]); + key = Tcl_GetString(objv[2]); + + *offset = 3; /* Consumed three arguments: cmd, array, key */ + + /* + * Lock the shared array and locate the shared object + */ + + arrayPtr = LockArray(interp, array, flags); + if (arrayPtr == NULL) { + return TCL_BREAK; + } + *retObj = AcquireContainer(arrayPtr, Tcl_GetString(objv[2]), flags); + if (*retObj == NULL) { + UnlockArray(arrayPtr); + Tcl_AppendResult(interp, "no key ", array, "(", key, ")", (void *)NULL); + return TCL_BREAK; + } } else { - Tcl_HashTable *handles = &((*retObj)->bucketPtr->handles); - LOCK_CONTAINER(*retObj); - if (Tcl_FindHashEntry(handles, (char*)(*retObj)) == NULL) { - UNLOCK_CONTAINER(*retObj); - Tcl_SetObjResult(interp, Tcl_NewStringObj("key has been deleted", TCL_INDEX_NONE)); - return TCL_BREAK; - } - *offset = 2; /* Consumed two arguments: object, cmd */ + Tcl_HashTable *handles = &((*retObj)->bucketPtr->handles); + LOCK_CONTAINER(*retObj); + if (Tcl_FindHashEntry(handles, (char*)(*retObj)) == NULL) { + UNLOCK_CONTAINER(*retObj); + Tcl_SetObjResult(interp, Tcl_NewStringObj("key has been deleted", TCL_INDEX_NONE)); + return TCL_BREAK; + } + *offset = 2; /* Consumed two arguments: object, cmd */ } return TCL_OK; @@ -377,9 +377,9 @@ Sv_GetContainer( int Sv_PutContainer( - Tcl_Interp *interp, /* For error reporting; might be NULL */ - Container *svObj, /* Shared object container */ - int mode) /* One of SV_XXX modes */ + Tcl_Interp *interp, /* For error reporting; might be NULL */ + Container *svObj, /* Shared object container */ + int mode) /* One of SV_XXX modes */ { int ret; @@ -432,22 +432,22 @@ GetPsStore(const char *handle) */ for (i = 0; i < NUMBUCKETS; i++) { - Tcl_HashSearch search; - Tcl_HashEntry *hPtr; - Bucket *bucketPtr = &buckets[i]; - LOCK_BUCKET(bucketPtr); - hPtr = Tcl_FirstHashEntry(&bucketPtr->arrays, &search); - while (hPtr) { - Array *arrayPtr = (Array*)Tcl_GetHashValue(hPtr); - if (arrayPtr->bindAddr && arrayPtr->psPtr) { - if (strcmp(arrayPtr->bindAddr, handle) == 0) { - UNLOCK_BUCKET(bucketPtr); - return NULL; /* Array already bound */ - } - } - hPtr = Tcl_NextHashEntry(&search); - } - UNLOCK_BUCKET(bucketPtr); + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + Bucket *bucketPtr = &buckets[i]; + LOCK_BUCKET(bucketPtr); + hPtr = Tcl_FirstHashEntry(&bucketPtr->arrays, &search); + while (hPtr) { + Array *arrayPtr = (Array*)Tcl_GetHashValue(hPtr); + if (arrayPtr->bindAddr && arrayPtr->psPtr) { + if (strcmp(arrayPtr->bindAddr, handle) == 0) { + UNLOCK_BUCKET(bucketPtr); + return NULL; /* Array already bound */ + } + } + hPtr = Tcl_NextHashEntry(&search); + } + UNLOCK_BUCKET(bucketPtr); } /* @@ -455,10 +455,10 @@ GetPsStore(const char *handle) */ if (delimiter == NULL) { - addr = NULL; + addr = NULL; } else { - *delimiter = 0; - addr = delimiter + 1; + *delimiter = 0; + addr = delimiter + 1; } /* @@ -468,20 +468,20 @@ GetPsStore(const char *handle) Tcl_MutexLock(&svMutex); for (tmpPtr = psStore; tmpPtr; tmpPtr = tmpPtr->nextPtr) { - if (strcmp(tmpPtr->type, type) == 0) { - tmpPtr->psHandle = tmpPtr->psOpen(addr); - if (tmpPtr->psHandle) { - psPtr = (PsStore*)ckalloc(sizeof(PsStore)); - *psPtr = *tmpPtr; - psPtr->nextPtr = NULL; - } - break; - } + if (strcmp(tmpPtr->type, type) == 0) { + tmpPtr->psHandle = tmpPtr->psOpen(addr); + if (tmpPtr->psHandle) { + psPtr = (PsStore*)ckalloc(sizeof(PsStore)); + *psPtr = *tmpPtr; + psPtr->nextPtr = NULL; + } + break; + } } Tcl_MutexUnlock(&svMutex); if (delimiter) { - *delimiter = ':'; + *delimiter = ':'; } return psPtr; @@ -506,32 +506,32 @@ GetPsStore(const char *handle) static Container * AcquireContainer( - Array *arrayPtr, - const char *key, - int flags) + Array *arrayPtr, + const char *key, + int flags) { int isNew; Tcl_Obj *tclObj = NULL; Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&arrayPtr->vars, key); if (hPtr == NULL) { - PsStore *psPtr = arrayPtr->psPtr; - if (psPtr) { - char *val = NULL; - size_t len = 0; - if (psPtr->psGet(psPtr->psHandle, key, &val, &len) == 0) { - tclObj = Tcl_NewStringObj(val, len); - psPtr->psFree(psPtr->psHandle, val); - } - } - if (!(flags & FLAGS_CREATEVAR) && tclObj == NULL) { - return NULL; - } - if (tclObj == NULL) { - tclObj = Tcl_NewObj(); - } - hPtr = Tcl_CreateHashEntry(&arrayPtr->vars, key, &isNew); - Tcl_SetHashValue(hPtr, CreateContainer(arrayPtr, hPtr, tclObj)); + PsStore *psPtr = arrayPtr->psPtr; + if (psPtr) { + char *val = NULL; + size_t len = 0; + if (psPtr->psGet(psPtr->psHandle, key, &val, &len) == 0) { + tclObj = Tcl_NewStringObj(val, len); + psPtr->psFree(psPtr->psHandle, val); + } + } + if (!(flags & FLAGS_CREATEVAR) && tclObj == NULL) { + return NULL; + } + if (tclObj == NULL) { + tclObj = Tcl_NewObj(); + } + hPtr = Tcl_CreateHashEntry(&arrayPtr->vars, key, &isNew); + Tcl_SetHashValue(hPtr, CreateContainer(arrayPtr, hPtr, tclObj)); } return (Container*)Tcl_GetHashValue(hPtr); @@ -557,9 +557,9 @@ AcquireContainer( static int ReleaseContainer( - Tcl_Interp *interp, - Container *svObj, - int mode) + Tcl_Interp *interp, + Container *svObj, + int mode) { const PsStore *psPtr = svObj->arrayPtr->psPtr; size_t len; @@ -569,17 +569,17 @@ ReleaseContainer( case SV_UNCHANGED: return TCL_OK; case SV_ERROR: return TCL_ERROR; case SV_CHANGED: - if (psPtr) { - key = (char *)Tcl_GetHashKey(&svObj->arrayPtr->vars, svObj->entryPtr); - val = Tcl_GetString(svObj->tclObj); - len = svObj->tclObj->length; - if (psPtr->psPut(psPtr->psHandle, key, val, len) == -1) { - const char *err = psPtr->psError(psPtr->psHandle); - Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_INDEX_NONE)); - return TCL_ERROR; - } - } - return TCL_OK; + if (psPtr) { + key = (char *)Tcl_GetHashKey(&svObj->arrayPtr->vars, svObj->entryPtr); + val = Tcl_GetString(svObj->tclObj); + len = svObj->tclObj->length; + if (psPtr->psPut(psPtr->psHandle, key, val, len) == -1) { + const char *err = psPtr->psError(psPtr->psHandle); + Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_INDEX_NONE)); + return TCL_ERROR; + } + } + return TCL_OK; } return TCL_ERROR; /* Should never be reached */ @@ -604,14 +604,14 @@ ReleaseContainer( static Container * CreateContainer( - Array *arrayPtr, - Tcl_HashEntry *entryPtr, - Tcl_Obj *tclObj) + Array *arrayPtr, + Tcl_HashEntry *entryPtr, + Tcl_Obj *tclObj) { Container *svObj; if (arrayPtr->bucketPtr->freeCt == NULL) { - SvAllocateContainers(arrayPtr->bucketPtr); + SvAllocateContainers(arrayPtr->bucketPtr); } svObj = arrayPtr->bucketPtr->freeCt; @@ -624,7 +624,7 @@ CreateContainer( svObj->handlePtr = NULL; if (svObj->tclObj) { - Tcl_IncrRefCount(svObj->tclObj); + Tcl_IncrRefCount(svObj->tclObj); } return svObj; @@ -650,23 +650,23 @@ CreateContainer( static int DeleteContainer( - Container *svObj) + Container *svObj) { if (svObj->tclObj) { - Tcl_DecrRefCount(svObj->tclObj); + Tcl_DecrRefCount(svObj->tclObj); } if (svObj->handlePtr) { - Tcl_DeleteHashEntry(svObj->handlePtr); + Tcl_DeleteHashEntry(svObj->handlePtr); } if (svObj->entryPtr) { - PsStore *psPtr = svObj->arrayPtr->psPtr; - if (psPtr) { - char *key = (char *)Tcl_GetHashKey(&svObj->arrayPtr->vars,svObj->entryPtr); - if (psPtr->psDelete(psPtr->psHandle, key) == -1) { - return TCL_ERROR; - } - } - Tcl_DeleteHashEntry(svObj->entryPtr); + PsStore *psPtr = svObj->arrayPtr->psPtr; + if (psPtr) { + char *key = (char *)Tcl_GetHashKey(&svObj->arrayPtr->vars,svObj->entryPtr); + if (psPtr->psDelete(psPtr->psHandle, key) == -1) { + return TCL_ERROR; + } + } + Tcl_DeleteHashEntry(svObj->entryPtr); } svObj->arrayPtr = NULL; @@ -699,9 +699,9 @@ DeleteContainer( static Array * LockArray( - Tcl_Interp *interp, /* Interpreter to leave result. */ - const char *array, /* Name of array to lock */ - int flags) /* FLAGS_CREATEARRAY/FLAGS_NOERRMSG*/ + Tcl_Interp *interp, /* Interpreter to leave result. */ + const char *array, /* Name of array to lock */ + int flags) /* FLAGS_CREATEARRAY/FLAGS_NOERRMSG*/ { const char *p; unsigned int result; @@ -716,8 +716,8 @@ LockArray( p = array; result = 0; while (*p++) { - i = *p; - result += (result << 3) + i; + i = *p; + result += (result << 3) + i; } i = result % NUMBUCKETS; bucketPtr = &buckets[i]; @@ -729,18 +729,18 @@ LockArray( LOCK_BUCKET(bucketPtr); /* Note: no matching unlock below ! */ if (flags & FLAGS_CREATEARRAY) { - arrayPtr = CreateArray(bucketPtr, array); + arrayPtr = CreateArray(bucketPtr, array); } else { - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&bucketPtr->arrays, array); - if (hPtr == NULL) { - UNLOCK_BUCKET(bucketPtr); - if (!(flags & FLAGS_NOERRMSG)) { - Tcl_AppendResult(interp, "\"", array, - "\" is not a thread shared array", (void *)NULL); - } - return NULL; - } - arrayPtr = (Array*)Tcl_GetHashValue(hPtr); + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&bucketPtr->arrays, array); + if (hPtr == NULL) { + UNLOCK_BUCKET(bucketPtr); + if (!(flags & FLAGS_NOERRMSG)) { + Tcl_AppendResult(interp, "\"", array, + "\" is not a thread shared array", (void *)NULL); + } + return NULL; + } + arrayPtr = (Array*)Tcl_GetHashValue(hPtr); } return arrayPtr; @@ -769,10 +769,10 @@ FlushArray(Array *arrayPtr) /* Name of array to flush */ Tcl_HashSearch search; for (hPtr = Tcl_FirstHashEntry(&arrayPtr->vars, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { - if (DeleteContainer((Container*)Tcl_GetHashValue(hPtr)) != TCL_OK) { - return TCL_ERROR; - } + hPtr = Tcl_NextHashEntry(&search)) { + if (DeleteContainer((Container*)Tcl_GetHashValue(hPtr)) != TCL_OK) { + return TCL_ERROR; + } } return TCL_OK; @@ -796,8 +796,8 @@ FlushArray(Array *arrayPtr) /* Name of array to flush */ static Array * CreateArray( - Bucket *bucketPtr, - const char *arrayName) + Bucket *bucketPtr, + const char *arrayName) { int isNew; Array *arrayPtr; @@ -805,7 +805,7 @@ CreateArray( hPtr = Tcl_CreateHashEntry(&bucketPtr->arrays, arrayName, &isNew); if (!isNew) { - return (Array*)Tcl_GetHashValue(hPtr); + return (Array*)Tcl_GetHashValue(hPtr); } arrayPtr = (Array *)ckalloc(sizeof(Array)); @@ -841,19 +841,19 @@ UnbindArray(Tcl_Interp *interp, Array *arrayPtr) { PsStore *psPtr = arrayPtr->psPtr; if (arrayPtr->bindAddr) { - ckfree(arrayPtr->bindAddr); - arrayPtr->bindAddr = NULL; + ckfree(arrayPtr->bindAddr); + arrayPtr->bindAddr = NULL; } if (psPtr) { - if (psPtr->psClose(psPtr->psHandle) == -1) { - if (interp) { - const char *err = psPtr->psError(psPtr->psHandle); - Tcl_SetObjResult(interp, Tcl_NewStringObj(err, -1)); - } - return TCL_ERROR; - } - ckfree((char *)arrayPtr->psPtr), arrayPtr->psPtr = NULL; - arrayPtr->psPtr = NULL; + if (psPtr->psClose(psPtr->psHandle) == -1) { + if (interp) { + const char *err = psPtr->psError(psPtr->psHandle); + Tcl_SetObjResult(interp, Tcl_NewStringObj(err, -1)); + } + return TCL_ERROR; + } + ckfree((char *)arrayPtr->psPtr), arrayPtr->psPtr = NULL; + arrayPtr->psPtr = NULL; } return TCL_OK; } @@ -862,15 +862,15 @@ static int DeleteArray(Tcl_Interp *interp, Array *arrayPtr) { if (FlushArray(arrayPtr) == -1) { - return TCL_ERROR; + return TCL_ERROR; } if (arrayPtr->psPtr) { - if (UnbindArray(interp, arrayPtr) != TCL_OK) { - return TCL_ERROR; - }; + if (UnbindArray(interp, arrayPtr) != TCL_OK) { + return TCL_ERROR; + }; } if (arrayPtr->entryPtr) { - Tcl_DeleteHashEntry(arrayPtr->entryPtr); + Tcl_DeleteHashEntry(arrayPtr->entryPtr); } Tcl_DeleteHashTable(&arrayPtr->vars); @@ -913,9 +913,9 @@ SvAllocateContainers(Bucket *bucketPtr) objPtr->chunkAddr = basePtr; /* Mark chunk address for reclaim */ for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { - objPtr->nextPtr = prevPtr; - prevPtr = objPtr; - objPtr = (Container*)(((char*)objPtr) + objSizePlusPadding); + objPtr->nextPtr = prevPtr; + prevPtr = objPtr; + objPtr = (Container*)(((char*)objPtr) + objSizePlusPadding); } bucketPtr->freeCt = prevPtr; } @@ -943,13 +943,13 @@ SvFinalizeContainers(Bucket *bucketPtr) Container *tmpPtr, *objPtr = bucketPtr->freeCt; while (objPtr) { - if (objPtr->chunkAddr == (char*)objPtr) { - tmpPtr = objPtr->nextPtr; - ckfree((char *)objPtr); - objPtr = tmpPtr; - } else { - objPtr = objPtr->nextPtr; - } + if (objPtr->chunkAddr == (char*)objPtr) { + tmpPtr = objPtr->nextPtr; + ckfree((char *)objPtr); + objPtr = tmpPtr; + } else { + objPtr = objPtr->nextPtr; + } } } #endif /* SV_FINALIZE */ @@ -1005,52 +1005,52 @@ Sv_DuplicateObj( */ if (objPtr->typePtr != NULL) { - if (objPtr->typePtr->dupIntRepProc == NULL) { - dupPtr->internalRep = objPtr->internalRep; - dupPtr->typePtr = objPtr->typePtr; - Tcl_InvalidateStringRep(dupPtr); - } else { - if ( objPtr->typePtr == booleanObjTypePtr \ - || objPtr->typePtr == byteArrayObjTypePtr \ - || objPtr->typePtr == doubleObjTypePtr \ - || objPtr->typePtr == intObjTypePtr \ - || objPtr->typePtr == wideIntObjTypePtr \ - || objPtr->typePtr == stringObjTypePtr) { - /* - * Cover all "safe" obj types (see header comment) - */ - (*objPtr->typePtr->dupIntRepProc)(objPtr, dupPtr); - if (dupPtr->typePtr != NULL) { - Tcl_InvalidateStringRep(dupPtr); - } - } else { - int found = 0; - RegType *regPtr; - /* - * Cover special registered types. Assume not - * very many of those, so this sequential walk - * should be fast enough. - */ - for (regPtr = regType; regPtr; regPtr = regPtr->nextPtr) { - if (objPtr->typePtr == regPtr->typePtr) { - (*regPtr->dupIntRepProc)(objPtr, dupPtr); - if (dupPtr->typePtr != NULL) { - Tcl_InvalidateStringRep(dupPtr); - } - found = 1; - break; - } - } - /* - * Assure at least string rep of the source - * is present, which will be copied below. - */ - if (found == 0 && objPtr->bytes == NULL - && objPtr->typePtr->updateStringProc != NULL) { - (*objPtr->typePtr->updateStringProc)(objPtr); - } - } - } + if (objPtr->typePtr->dupIntRepProc == NULL) { + dupPtr->internalRep = objPtr->internalRep; + dupPtr->typePtr = objPtr->typePtr; + Tcl_InvalidateStringRep(dupPtr); + } else { + if ( objPtr->typePtr == booleanObjTypePtr \ + || objPtr->typePtr == byteArrayObjTypePtr \ + || objPtr->typePtr == doubleObjTypePtr \ + || objPtr->typePtr == intObjTypePtr \ + || objPtr->typePtr == wideIntObjTypePtr \ + || objPtr->typePtr == stringObjTypePtr) { + /* + * Cover all "safe" obj types (see header comment) + */ + (*objPtr->typePtr->dupIntRepProc)(objPtr, dupPtr); + if (dupPtr->typePtr != NULL) { + Tcl_InvalidateStringRep(dupPtr); + } + } else { + int found = 0; + RegType *regPtr; + /* + * Cover special registered types. Assume not + * very many of those, so this sequential walk + * should be fast enough. + */ + for (regPtr = regType; regPtr; regPtr = regPtr->nextPtr) { + if (objPtr->typePtr == regPtr->typePtr) { + (*regPtr->dupIntRepProc)(objPtr, dupPtr); + if (dupPtr->typePtr != NULL) { + Tcl_InvalidateStringRep(dupPtr); + } + found = 1; + break; + } + } + /* + * Assure at least string rep of the source + * is present, which will be copied below. + */ + if (found == 0 && objPtr->bytes == NULL + && objPtr->typePtr->updateStringProc != NULL) { + (*objPtr->typePtr->updateStringProc)(objPtr); + } + } + } } /* @@ -1094,17 +1094,17 @@ Sv_DuplicateObj( static int SvObjDispatchObjCmd( - void *arg, /* Pointer to object container. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + void *arg, /* Pointer to object container. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { const char *cmdName; SvCmdInfo *cmdPtr; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "args"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "args"); + return TCL_ERROR; } cmdName = Tcl_GetString(objv[1]); @@ -1117,9 +1117,9 @@ SvObjDispatchObjCmd( */ for (cmdPtr = svCmdInfo; cmdPtr; cmdPtr = cmdPtr->nextPtr) { - if (!strcmp(cmdPtr->name, cmdName)) { - return (*cmdPtr->objProcPtr)(arg, interp, objc, objv); - } + if (!strcmp(cmdPtr->name, cmdName)) { + return (*cmdPtr->objProcPtr)(arg, interp, objc, objv); + } } Tcl_AppendResult(interp, "invalid command name \"", cmdName, "\"", (void *)NULL); @@ -1144,10 +1144,10 @@ SvObjDispatchObjCmd( static int SvObjObjCmd( - void *arg, /* != NULL if aolSpecial */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + void *arg, /* != NULL if aolSpecial */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int isNew, off, ret, flg; char buf[128]; @@ -1161,26 +1161,26 @@ SvObjObjCmd( ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); switch (ret) { case TCL_BREAK: /* Shared array was not found */ - if ((objc - off)) { - val = objv[off]; - } - Tcl_ResetResult(interp); - flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR; - ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg); - if (ret != TCL_OK) { - return TCL_ERROR; - } - Tcl_DecrRefCount(svObj->tclObj); - svObj->tclObj = Sv_DuplicateObj(val ? val : Tcl_NewObj()); - Tcl_IncrRefCount(svObj->tclObj); - break; + if ((objc - off)) { + val = objv[off]; + } + Tcl_ResetResult(interp); + flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR; + ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg); + if (ret != TCL_OK) { + return TCL_ERROR; + } + Tcl_DecrRefCount(svObj->tclObj); + svObj->tclObj = Sv_DuplicateObj(val ? val : Tcl_NewObj()); + Tcl_IncrRefCount(svObj->tclObj); + break; case TCL_ERROR: - return TCL_ERROR; + return TCL_ERROR; } if (svObj->handlePtr == NULL) { - Tcl_HashTable *handles = &svObj->arrayPtr->bucketPtr->handles; - svObj->handlePtr = Tcl_CreateHashEntry(handles, (char*)svObj, &isNew); + Tcl_HashTable *handles = &svObj->arrayPtr->bucketPtr->handles; + svObj->handlePtr = Tcl_CreateHashEntry(handles, (char*)svObj, &isNew); } /* @@ -1215,10 +1215,10 @@ SvObjObjCmd( static int SvArrayObjCmd( - void *arg, /* Pointer to object container. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + void *arg, /* Pointer to object container. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int i, argx = 0, lobjc = 0, index, ret = TCL_OK; const char *arrayName = NULL; @@ -1227,199 +1227,199 @@ SvArrayObjCmd( Container *svObj, *elObj = NULL; static const char *const opts[] = { - "set", "reset", "get", "names", "size", "exists", "isbound", - "bind", "unbind", NULL + "set", "reset", "get", "names", "size", "exists", "isbound", + "bind", "unbind", NULL }; enum options { - ASET, ARESET, AGET, ANAMES, ASIZE, AEXISTS, AISBOUND, - ABIND, AUNBIND + ASET, ARESET, AGET, ANAMES, ASIZE, AEXISTS, AISBOUND, + ABIND, AUNBIND }; svObj = (Container*)arg; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "option array"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "option array"); + return TCL_ERROR; } arrayName = Tcl_GetString(objv[2]); arrayPtr = LockArray(interp, arrayName, FLAGS_NOERRMSG); if (objc > 3) { - argx = 3; + argx = 3; } Tcl_ResetResult(interp); if (Tcl_GetIndexFromObjStruct(interp,objv[1],opts, sizeof(char *),"option",0,&index) != TCL_OK) { - ret = TCL_ERROR; + ret = TCL_ERROR; } else if (index == AEXISTS) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), arrayPtr!=0); + Tcl_SetIntObj(Tcl_GetObjResult(interp), arrayPtr!=0); } else if (index == AISBOUND) { - if (arrayPtr == NULL) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - } else { - Tcl_SetIntObj(Tcl_GetObjResult(interp), arrayPtr->psPtr!=0); - } + if (arrayPtr == NULL) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + } else { + Tcl_SetIntObj(Tcl_GetObjResult(interp), arrayPtr->psPtr!=0); + } } else if (index == ASIZE) { - if (arrayPtr == NULL) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - } else { - Tcl_SetWideIntObj(Tcl_GetObjResult(interp),arrayPtr->vars.numEntries); - } + if (arrayPtr == NULL) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + } else { + Tcl_SetWideIntObj(Tcl_GetObjResult(interp),arrayPtr->vars.numEntries); + } } else if (index == ASET || index == ARESET) { - if (argx == (objc - 1)) { - if (argx && Tcl_ListObjGetElements(interp, objv[argx], &lobjc, - &lobjv) != TCL_OK) { - ret = TCL_ERROR; - goto cmdExit; - } - } else { - lobjc = objc - 3; - lobjv = (Tcl_Obj**)objv + 3; - } - if (lobjc & 1) { - Tcl_AppendResult(interp, "list must have an even number" - " of elements", (void *)NULL); - ret = TCL_ERROR; - goto cmdExit; - } - if (arrayPtr == NULL) { - arrayPtr = LockArray(interp, arrayName, FLAGS_CREATEARRAY); - } - if (index == ARESET) { - ret = FlushArray(arrayPtr); - if (ret != TCL_OK) { - if (arrayPtr->psPtr) { - PsStore *psPtr = arrayPtr->psPtr; - const char *err = psPtr->psError(psPtr->psHandle); - Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_INDEX_NONE)); - } - goto cmdExit; - } - } - for (i = 0; i < lobjc; i += 2) { - const char *key = Tcl_GetString(lobjv[i]); - elObj = AcquireContainer(arrayPtr, key, FLAGS_CREATEVAR); - Tcl_DecrRefCount(elObj->tclObj); - elObj->tclObj = Sv_DuplicateObj(lobjv[i+1]); - Tcl_IncrRefCount(elObj->tclObj); - if (ReleaseContainer(interp, elObj, SV_CHANGED) != TCL_OK) { - ret = TCL_ERROR; - goto cmdExit; - } - } + if (argx == (objc - 1)) { + if (argx && Tcl_ListObjGetElements(interp, objv[argx], &lobjc, + &lobjv) != TCL_OK) { + ret = TCL_ERROR; + goto cmdExit; + } + } else { + lobjc = objc - 3; + lobjv = (Tcl_Obj**)objv + 3; + } + if (lobjc & 1) { + Tcl_AppendResult(interp, "list must have an even number" + " of elements", (void *)NULL); + ret = TCL_ERROR; + goto cmdExit; + } + if (arrayPtr == NULL) { + arrayPtr = LockArray(interp, arrayName, FLAGS_CREATEARRAY); + } + if (index == ARESET) { + ret = FlushArray(arrayPtr); + if (ret != TCL_OK) { + if (arrayPtr->psPtr) { + PsStore *psPtr = arrayPtr->psPtr; + const char *err = psPtr->psError(psPtr->psHandle); + Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_INDEX_NONE)); + } + goto cmdExit; + } + } + for (i = 0; i < lobjc; i += 2) { + const char *key = Tcl_GetString(lobjv[i]); + elObj = AcquireContainer(arrayPtr, key, FLAGS_CREATEVAR); + Tcl_DecrRefCount(elObj->tclObj); + elObj->tclObj = Sv_DuplicateObj(lobjv[i+1]); + Tcl_IncrRefCount(elObj->tclObj); + if (ReleaseContainer(interp, elObj, SV_CHANGED) != TCL_OK) { + ret = TCL_ERROR; + goto cmdExit; + } + } } else if (index == AGET || index == ANAMES) { - if (arrayPtr) { - Tcl_HashSearch search; - Tcl_Obj *resObj = Tcl_NewListObj(0, NULL); - const char *pattern = (argx == 0) ? NULL : Tcl_GetString(objv[argx]); - Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(&arrayPtr->vars,&search); - while (hPtr) { - char *key = (char *)Tcl_GetHashKey(&arrayPtr->vars, hPtr); - if (pattern == NULL || Tcl_StringCaseMatch(key, pattern, 0)) { - Tcl_ListObjAppendElement(interp, resObj, - Tcl_NewStringObj(key, TCL_INDEX_NONE)); - if (index == AGET) { - elObj = (Container*)Tcl_GetHashValue(hPtr); - Tcl_ListObjAppendElement(interp, resObj, - Sv_DuplicateObj(elObj->tclObj)); - } - } - hPtr = Tcl_NextHashEntry(&search); - } - Tcl_SetObjResult(interp, resObj); - } + if (arrayPtr) { + Tcl_HashSearch search; + Tcl_Obj *resObj = Tcl_NewListObj(0, NULL); + const char *pattern = (argx == 0) ? NULL : Tcl_GetString(objv[argx]); + Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(&arrayPtr->vars,&search); + while (hPtr) { + char *key = (char *)Tcl_GetHashKey(&arrayPtr->vars, hPtr); + if (pattern == NULL || Tcl_StringCaseMatch(key, pattern, 0)) { + Tcl_ListObjAppendElement(interp, resObj, + Tcl_NewStringObj(key, TCL_INDEX_NONE)); + if (index == AGET) { + elObj = (Container*)Tcl_GetHashValue(hPtr); + Tcl_ListObjAppendElement(interp, resObj, + Sv_DuplicateObj(elObj->tclObj)); + } + } + hPtr = Tcl_NextHashEntry(&search); + } + Tcl_SetObjResult(interp, resObj); + } } else if (index == ABIND) { - /* - * This is more complex operation, requiring some clarification. - * - * When binding an already existing array, we walk the array - * first and store all key/value pairs found there in the - * persistent storage. Then we proceed with the below. - * - * When binding an non-existent array, we open the persistent - * storage and cache all key/value pairs found there into tne - * newly created shared array. - */ - - PsStore *psPtr; - Tcl_HashEntry *hPtr; - size_t len; - int isNew; - char *psurl, *key = NULL, *val = NULL; - - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "array handle"); - ret = TCL_ERROR; - goto cmdExit; - } - - if (arrayPtr && arrayPtr->psPtr) { - Tcl_AppendResult(interp, "array is already bound", (void *)NULL); - ret = TCL_ERROR; - goto cmdExit; - } - - psurl = Tcl_GetString(objv[3]); - len = objv[3]->length; - psPtr = GetPsStore(psurl); - - if (psPtr == NULL) { - Tcl_AppendResult(interp, "can't open persistent storage on \"", - psurl, "\"", (void *)NULL); - ret = TCL_ERROR; - goto cmdExit; - } - if (arrayPtr) { - Tcl_HashSearch search; - hPtr = Tcl_FirstHashEntry(&arrayPtr->vars,&search); - arrayPtr->psPtr = psPtr; - arrayPtr->bindAddr = strcpy((char *)ckalloc(len+1), psurl); - while (hPtr) { - svObj = (Container *)Tcl_GetHashValue(hPtr); - if (ReleaseContainer(interp, svObj, SV_CHANGED) != TCL_OK) { - ret = TCL_ERROR; - goto cmdExit; - } - hPtr = Tcl_NextHashEntry(&search); - } - } else { - arrayPtr = LockArray(interp, arrayName, FLAGS_CREATEARRAY); - arrayPtr->psPtr = psPtr; - arrayPtr->bindAddr = strcpy((char *)ckalloc(len+1), psurl); - } - if (!psPtr->psFirst(psPtr->psHandle, &key, &val, &len)) { - do { - Tcl_Obj * tclObj = Tcl_NewStringObj(val, len); - hPtr = Tcl_CreateHashEntry(&arrayPtr->vars, key, &isNew); - Tcl_SetHashValue(hPtr, CreateContainer(arrayPtr, hPtr, tclObj)); - psPtr->psFree(psPtr->psHandle, val); - } while (!psPtr->psNext(psPtr->psHandle, &key, &val, &len)); - } + /* + * This is more complex operation, requiring some clarification. + * + * When binding an already existing array, we walk the array + * first and store all key/value pairs found there in the + * persistent storage. Then we proceed with the below. + * + * When binding an non-existent array, we open the persistent + * storage and cache all key/value pairs found there into tne + * newly created shared array. + */ + + PsStore *psPtr; + Tcl_HashEntry *hPtr; + size_t len; + int isNew; + char *psurl, *key = NULL, *val = NULL; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "array handle"); + ret = TCL_ERROR; + goto cmdExit; + } + + if (arrayPtr && arrayPtr->psPtr) { + Tcl_AppendResult(interp, "array is already bound", (void *)NULL); + ret = TCL_ERROR; + goto cmdExit; + } + + psurl = Tcl_GetString(objv[3]); + len = objv[3]->length; + psPtr = GetPsStore(psurl); + + if (psPtr == NULL) { + Tcl_AppendResult(interp, "can't open persistent storage on \"", + psurl, "\"", (void *)NULL); + ret = TCL_ERROR; + goto cmdExit; + } + if (arrayPtr) { + Tcl_HashSearch search; + hPtr = Tcl_FirstHashEntry(&arrayPtr->vars,&search); + arrayPtr->psPtr = psPtr; + arrayPtr->bindAddr = strcpy((char *)ckalloc(len+1), psurl); + while (hPtr) { + svObj = (Container *)Tcl_GetHashValue(hPtr); + if (ReleaseContainer(interp, svObj, SV_CHANGED) != TCL_OK) { + ret = TCL_ERROR; + goto cmdExit; + } + hPtr = Tcl_NextHashEntry(&search); + } + } else { + arrayPtr = LockArray(interp, arrayName, FLAGS_CREATEARRAY); + arrayPtr->psPtr = psPtr; + arrayPtr->bindAddr = strcpy((char *)ckalloc(len+1), psurl); + } + if (!psPtr->psFirst(psPtr->psHandle, &key, &val, &len)) { + do { + Tcl_Obj * tclObj = Tcl_NewStringObj(val, len); + hPtr = Tcl_CreateHashEntry(&arrayPtr->vars, key, &isNew); + Tcl_SetHashValue(hPtr, CreateContainer(arrayPtr, hPtr, tclObj)); + psPtr->psFree(psPtr->psHandle, val); + } while (!psPtr->psNext(psPtr->psHandle, &key, &val, &len)); + } } else if (index == AUNBIND) { - if (!arrayPtr || !arrayPtr->psPtr) { - Tcl_AppendResult(interp, "shared variable is not bound", (void *)NULL); - ret = TCL_ERROR; - goto cmdExit; - } - if (UnbindArray(interp, arrayPtr) != TCL_OK) { - ret = TCL_ERROR; - goto cmdExit; - } + if (!arrayPtr || !arrayPtr->psPtr) { + Tcl_AppendResult(interp, "shared variable is not bound", (void *)NULL); + ret = TCL_ERROR; + goto cmdExit; + } + if (UnbindArray(interp, arrayPtr) != TCL_OK) { + ret = TCL_ERROR; + goto cmdExit; + } } cmdExit: if (arrayPtr) { - UnlockArray(arrayPtr); + UnlockArray(arrayPtr); } return ret; @@ -1444,48 +1444,48 @@ SvArrayObjCmd( static int SvUnsetObjCmd( - TCL_UNUSED(void *), /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + TCL_UNUSED(void *), /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int ii; const char *arrayName; Array *arrayPtr; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "array ?key ...?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "array ?key ...?"); + return TCL_ERROR; } arrayName = Tcl_GetString(objv[1]); arrayPtr = LockArray(interp, arrayName, 0); if (arrayPtr == NULL) { - return TCL_ERROR; + return TCL_ERROR; } if (objc == 2) { - UnlockArray(arrayPtr); - if (DeleteArray(interp, arrayPtr) != TCL_OK) { - return TCL_ERROR; - } + UnlockArray(arrayPtr); + if (DeleteArray(interp, arrayPtr) != TCL_OK) { + return TCL_ERROR; + } } else { - for (ii = 2; ii < objc; ii++) { - const char *key = Tcl_GetString(objv[ii]); - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&arrayPtr->vars, key); - if (hPtr) { - if (DeleteContainer((Container*)Tcl_GetHashValue(hPtr)) - != TCL_OK) { - UnlockArray(arrayPtr); - return TCL_ERROR; - } - } else { - UnlockArray(arrayPtr); - Tcl_AppendResult(interp,"no key ",arrayName,"(",key,")",(void *)NULL); - return TCL_ERROR; - } - } - UnlockArray(arrayPtr); + for (ii = 2; ii < objc; ii++) { + const char *key = Tcl_GetString(objv[ii]); + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&arrayPtr->vars, key); + if (hPtr) { + if (DeleteContainer((Container*)Tcl_GetHashValue(hPtr)) + != TCL_OK) { + UnlockArray(arrayPtr); + return TCL_ERROR; + } + } else { + UnlockArray(arrayPtr); + Tcl_AppendResult(interp,"no key ",arrayName,"(",key,")",(void *)NULL); + return TCL_ERROR; + } + } + UnlockArray(arrayPtr); } return TCL_OK; @@ -1510,10 +1510,10 @@ SvUnsetObjCmd( static int SvNamesObjCmd( - void *arg, /* != NULL if aolSpecial */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + void *arg, /* != NULL if aolSpecial */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int i; const char *pattern = NULL; @@ -1522,29 +1522,29 @@ SvNamesObjCmd( Tcl_Obj *resObj; if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); + return TCL_ERROR; } if (objc == 2) { - pattern = Tcl_GetString(objv[1]); + pattern = Tcl_GetString(objv[1]); } resObj = Tcl_NewListObj(0, NULL); for (i = 0; i < NUMBUCKETS; i++) { - Bucket *bucketPtr = &buckets[i]; - LOCK_BUCKET(bucketPtr); - hPtr = Tcl_FirstHashEntry(&bucketPtr->arrays, &search); - while (hPtr) { - char *key = (char *)Tcl_GetHashKey(&bucketPtr->arrays, hPtr); - if ((arg==NULL || (*key != '.')) /* Hide . arrays for AOL*/ && - (pattern == NULL || Tcl_StringCaseMatch(key, pattern, 0))) { - Tcl_ListObjAppendElement(interp, resObj, - Tcl_NewStringObj(key, -1)); - } - hPtr = Tcl_NextHashEntry(&search); - } - UNLOCK_BUCKET(bucketPtr); + Bucket *bucketPtr = &buckets[i]; + LOCK_BUCKET(bucketPtr); + hPtr = Tcl_FirstHashEntry(&bucketPtr->arrays, &search); + while (hPtr) { + char *key = (char *)Tcl_GetHashKey(&bucketPtr->arrays, hPtr); + if ((arg==NULL || (*key != '.')) /* Hide . arrays for AOL*/ && + (pattern == NULL || Tcl_StringCaseMatch(key, pattern, 0))) { + Tcl_ListObjAppendElement(interp, resObj, + Tcl_NewStringObj(key, -1)); + } + hPtr = Tcl_NextHashEntry(&search); + } + UNLOCK_BUCKET(bucketPtr); } Tcl_SetObjResult(interp, resObj); @@ -1571,10 +1571,10 @@ SvNamesObjCmd( static int SvGetObjCmd( - void *arg, /* Pointer to object container. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + void *arg, /* Pointer to object container. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int off, ret; Tcl_Obj *res; @@ -1589,26 +1589,26 @@ SvGetObjCmd( ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); switch (ret) { case TCL_BREAK: - if ((objc - off) == 0) { - return TCL_ERROR; - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); - return TCL_OK; - } + if ((objc - off) == 0) { + return TCL_ERROR; + } else { + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + return TCL_OK; + } case TCL_ERROR: - return TCL_ERROR; + return TCL_ERROR; } res = Sv_DuplicateObj(svObj->tclObj); if ((objc - off) == 0) { - Tcl_SetObjResult(interp, res); + Tcl_SetObjResult(interp, res); } else { - if (Tcl_ObjSetVar2(interp, objv[off], NULL, res, 0) == NULL) { - Tcl_DecrRefCount(res); - goto cmd_err; - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); + if (Tcl_ObjSetVar2(interp, objv[off], NULL, res, 0) == NULL) { + Tcl_DecrRefCount(res); + goto cmd_err; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); } return Sv_PutContainer(interp, svObj, SV_UNCHANGED); @@ -1636,10 +1636,10 @@ SvGetObjCmd( static int SvExistsObjCmd( - void *arg, /* Pointer to object container. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + void *arg, /* Pointer to object container. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int off, ret; Container *svObj = (Container*)arg; @@ -1653,10 +1653,10 @@ SvExistsObjCmd( ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); switch (ret) { case TCL_BREAK: /* Array/key not found */ - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); - return TCL_OK; + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + return TCL_OK; case TCL_ERROR: - return TCL_ERROR; + return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); @@ -1683,10 +1683,10 @@ SvExistsObjCmd( static int SvSetObjCmd( - void *arg, /* Pointer to object container */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + void *arg, /* Pointer to object container */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int ret, off, flg, mode; Tcl_Obj *val; @@ -1701,29 +1701,29 @@ SvSetObjCmd( ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); switch (ret) { case TCL_BREAK: - if ((objc - off) == 0) { - return TCL_ERROR; - } else { - Tcl_ResetResult(interp); - flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR; - ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg); - if (ret != TCL_OK) { - return TCL_ERROR; - } - } - break; + if ((objc - off) == 0) { + return TCL_ERROR; + } else { + Tcl_ResetResult(interp); + flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR; + ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg); + if (ret != TCL_OK) { + return TCL_ERROR; + } + } + break; case TCL_ERROR: - return TCL_ERROR; + return TCL_ERROR; } if ((objc - off)) { - val = objv[off]; - Tcl_DecrRefCount(svObj->tclObj); - svObj->tclObj = Sv_DuplicateObj(val); - Tcl_IncrRefCount(svObj->tclObj); - mode = SV_CHANGED; + val = objv[off]; + Tcl_DecrRefCount(svObj->tclObj); + svObj->tclObj = Sv_DuplicateObj(val); + Tcl_IncrRefCount(svObj->tclObj); + mode = SV_CHANGED; } else { - val = Sv_DuplicateObj(svObj->tclObj); - mode = SV_UNCHANGED; + val = Sv_DuplicateObj(svObj->tclObj); + mode = SV_UNCHANGED; } Tcl_SetObjResult(interp, val); @@ -1750,10 +1750,10 @@ SvSetObjCmd( static int SvIncrObjCmd( - void *arg, /* Pointer to object container */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + void *arg, /* Pointer to object container */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int off, ret, flg, isNew = 0; Tcl_WideInt incrValue = 1, currValue = 0; @@ -1767,30 +1767,30 @@ SvIncrObjCmd( ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); if (ret != TCL_OK) { - if (ret != TCL_BREAK) { - return TCL_ERROR; - } - flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR; - Tcl_ResetResult(interp); - ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg); - if (ret != TCL_OK) { - return TCL_ERROR; - } - isNew = 1; + if (ret != TCL_BREAK) { + return TCL_ERROR; + } + flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR; + Tcl_ResetResult(interp); + ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg); + if (ret != TCL_OK) { + return TCL_ERROR; + } + isNew = 1; } if ((objc - off)) { - ret = Tcl_GetWideIntFromObj(interp, objv[off], &incrValue); - if (ret != TCL_OK) { - goto cmd_err; - } + ret = Tcl_GetWideIntFromObj(interp, objv[off], &incrValue); + if (ret != TCL_OK) { + goto cmd_err; + } } if (isNew) { - currValue = 0; + currValue = 0; } else { - ret = Tcl_GetWideIntFromObj(interp, svObj->tclObj, &currValue); - if (ret != TCL_OK) { - goto cmd_err; - } + ret = Tcl_GetWideIntFromObj(interp, svObj->tclObj, &currValue); + if (ret != TCL_OK) { + goto cmd_err; + } } incrValue += currValue; @@ -1823,10 +1823,10 @@ SvIncrObjCmd( static int SvAppendObjCmd( - void *arg, /* Pointer to object container */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + void *arg, /* Pointer to object container */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int i, off, flg, ret; Container *svObj = (Container*)arg; @@ -1840,14 +1840,14 @@ SvAppendObjCmd( flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR; ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg); if (ret != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } if ((objc - off) < 1) { - Tcl_WrongNumArgs(interp, off, objv, "value ?value ...?"); - goto cmd_err; + Tcl_WrongNumArgs(interp, off, objv, "value ?value ...?"); + goto cmd_err; } for (i = off; i < objc; ++i) { - Tcl_AppendObjToObj(svObj->tclObj, Sv_DuplicateObj(objv[i])); + Tcl_AppendObjToObj(svObj->tclObj, Sv_DuplicateObj(objv[i])); } Tcl_SetObjResult(interp, Sv_DuplicateObj(svObj->tclObj)); @@ -1877,10 +1877,10 @@ SvAppendObjCmd( static int SvPopObjCmd( - void *arg, /* Pointer to object container */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + void *arg, /* Pointer to object container */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int ret, off; Tcl_Obj *retObj; @@ -1898,14 +1898,14 @@ SvPopObjCmd( ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); switch (ret) { case TCL_BREAK: - if ((objc - off) == 0) { - return TCL_ERROR; - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); - return TCL_OK; - } + if ((objc - off) == 0) { + return TCL_ERROR; + } else { + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + return TCL_OK; + } case TCL_ERROR: - return TCL_ERROR; + return TCL_ERROR; } arrayPtr = svObj->arrayPtr; @@ -1914,23 +1914,23 @@ SvPopObjCmd( svObj->tclObj = NULL; if (DeleteContainer(svObj) != TCL_OK) { - if (svObj->arrayPtr->psPtr) { - PsStore *psPtr = svObj->arrayPtr->psPtr; - const char *err = psPtr->psError(psPtr->psHandle); - Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_INDEX_NONE)); - } - ret = TCL_ERROR; - goto cmd_exit; + if (svObj->arrayPtr->psPtr) { + PsStore *psPtr = svObj->arrayPtr->psPtr; + const char *err = psPtr->psError(psPtr->psHandle); + Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_INDEX_NONE)); + } + ret = TCL_ERROR; + goto cmd_exit; } if ((objc - off) == 0) { - Tcl_SetObjResult(interp, retObj); + Tcl_SetObjResult(interp, retObj); } else { - if (Tcl_ObjSetVar2(interp, objv[off], NULL, retObj, 0) == NULL) { - ret = TCL_ERROR; - goto cmd_exit; - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); + if (Tcl_ObjSetVar2(interp, objv[off], NULL, retObj, 0) == NULL) { + ret = TCL_ERROR; + goto cmd_exit; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); } cmd_exit: @@ -1960,10 +1960,10 @@ SvPopObjCmd( static int SvMoveObjCmd( - void *arg, /* Pointer to object container. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + void *arg, /* Pointer to object container. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int ret, off, isNew; const char *toKey; @@ -1978,27 +1978,27 @@ SvMoveObjCmd( ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); if (ret != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } toKey = Tcl_GetString(objv[off]); hPtr = Tcl_CreateHashEntry(&svObj->arrayPtr->vars, toKey, &isNew); if (!isNew) { - Tcl_AppendResult(interp, "key \"", toKey, "\" exists", (void *)NULL); - goto cmd_err; + Tcl_AppendResult(interp, "key \"", toKey, "\" exists", (void *)NULL); + goto cmd_err; } if (svObj->entryPtr) { - char *key = (char *)Tcl_GetHashKey(&svObj->arrayPtr->vars, svObj->entryPtr); - if (svObj->arrayPtr->psPtr) { - PsStore *psPtr = svObj->arrayPtr->psPtr; - if (psPtr->psDelete(psPtr->psHandle, key) == -1) { - const char *err = psPtr->psError(psPtr->psHandle); - Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_INDEX_NONE)); - return TCL_ERROR; - } - } - Tcl_DeleteHashEntry(svObj->entryPtr); + char *key = (char *)Tcl_GetHashKey(&svObj->arrayPtr->vars, svObj->entryPtr); + if (svObj->arrayPtr->psPtr) { + PsStore *psPtr = svObj->arrayPtr->psPtr; + if (psPtr->psDelete(psPtr->psHandle, key) == -1) { + const char *err = psPtr->psError(psPtr->psHandle); + Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_INDEX_NONE)); + return TCL_ERROR; + } + } + Tcl_DeleteHashEntry(svObj->entryPtr); } svObj->entryPtr = hPtr; @@ -2030,10 +2030,10 @@ SvMoveObjCmd( static int SvLockObjCmd( - TCL_UNUSED(void *), /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + TCL_UNUSED(void *), /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int ret; Tcl_Obj *scriptObj; @@ -2047,8 +2047,8 @@ SvLockObjCmd( */ if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "array arg ?arg...?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "array arg ?arg...?"); + return TCL_ERROR; } arrayPtr = LockArray(interp, Tcl_GetString(objv[1]), FLAGS_CREATEARRAY); @@ -2062,20 +2062,20 @@ SvLockObjCmd( */ if (objc == 3) { - scriptObj = Tcl_DuplicateObj(objv[2]); + scriptObj = Tcl_DuplicateObj(objv[2]); } else { - scriptObj = Tcl_ConcatObj(objc-2, objv + 2); + scriptObj = Tcl_ConcatObj(objc-2, objv + 2); } Tcl_AllowExceptions(interp); ret = Tcl_EvalObjEx(interp, scriptObj, TCL_EVAL_DIRECT); if (ret == TCL_ERROR) { - char msg[32 + TCL_INTEGER_SPACE]; - /* Next line generates a Deprecation warning when compiled with Tcl 8.6. - * See Tcl bug #3562640 */ - snprintf(msg, sizeof(msg), "\n (\"eval\" body line %d)", Tcl_GetErrorLine(interp)); - Tcl_AddErrorInfo(interp, msg); + char msg[32 + TCL_INTEGER_SPACE]; + /* Next line generates a Deprecation warning when compiled with Tcl 8.6. + * See Tcl bug #3562640 */ + snprintf(msg, sizeof(msg), "\n (\"eval\" body line %d)", Tcl_GetErrorLine(interp)); + Tcl_AddErrorInfo(interp, msg); } /* @@ -2106,10 +2106,10 @@ SvLockObjCmd( */ static int SvHandlersObjCmd( - TCL_UNUSED(void *), /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + TCL_UNUSED(void *), /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { PsStore *tmpPtr = NULL; @@ -2120,14 +2120,14 @@ SvHandlersObjCmd( */ if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, NULL); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; } Tcl_ResetResult(interp); Tcl_MutexLock(&svMutex); for (tmpPtr = psStore; tmpPtr; tmpPtr = tmpPtr->nextPtr) { - Tcl_AppendElement(interp, tmpPtr->type); + Tcl_AppendElement(interp, tmpPtr->type); } Tcl_MutexUnlock(&svMutex); @@ -2157,25 +2157,25 @@ SvRegisterStdCommands(void) static int initialized = 0; if (initialized == 0) { - Tcl_MutexLock(&initMutex); - if (initialized == 0) { - Sv_RegisterCommand("var", SvObjObjCmd, NULL, 1); - Sv_RegisterCommand("object", SvObjObjCmd, NULL, 1); - Sv_RegisterCommand("set", SvSetObjCmd, NULL, 0); - Sv_RegisterCommand("unset", SvUnsetObjCmd, NULL, 0); - Sv_RegisterCommand("get", SvGetObjCmd, NULL, 0); - Sv_RegisterCommand("incr", SvIncrObjCmd, NULL, 0); - Sv_RegisterCommand("exists", SvExistsObjCmd, NULL, 0); - Sv_RegisterCommand("append", SvAppendObjCmd, NULL, 0); - Sv_RegisterCommand("array", SvArrayObjCmd, NULL, 0); - Sv_RegisterCommand("names", SvNamesObjCmd, NULL, 0); - Sv_RegisterCommand("pop", SvPopObjCmd, NULL, 0); - Sv_RegisterCommand("move", SvMoveObjCmd, NULL, 0); - Sv_RegisterCommand("lock", SvLockObjCmd, NULL, 0); - Sv_RegisterCommand("handlers", SvHandlersObjCmd, NULL, 0); - initialized = 1; - } - Tcl_MutexUnlock(&initMutex); + Tcl_MutexLock(&initMutex); + if (initialized == 0) { + Sv_RegisterCommand("var", SvObjObjCmd, NULL, 1); + Sv_RegisterCommand("object", SvObjObjCmd, NULL, 1); + Sv_RegisterCommand("set", SvSetObjCmd, NULL, 0); + Sv_RegisterCommand("unset", SvUnsetObjCmd, NULL, 0); + Sv_RegisterCommand("get", SvGetObjCmd, NULL, 0); + Sv_RegisterCommand("incr", SvIncrObjCmd, NULL, 0); + Sv_RegisterCommand("exists", SvExistsObjCmd, NULL, 0); + Sv_RegisterCommand("append", SvAppendObjCmd, NULL, 0); + Sv_RegisterCommand("array", SvArrayObjCmd, NULL, 0); + Sv_RegisterCommand("names", SvNamesObjCmd, NULL, 0); + Sv_RegisterCommand("pop", SvPopObjCmd, NULL, 0); + Sv_RegisterCommand("move", SvMoveObjCmd, NULL, 0); + Sv_RegisterCommand("lock", SvLockObjCmd, NULL, 0); + Sv_RegisterCommand("handlers", SvHandlersObjCmd, NULL, 0); + initialized = 1; + } + Tcl_MutexUnlock(&initMutex); } } @@ -2270,11 +2270,11 @@ SvInit ( */ for (cmdPtr = svCmdInfo; cmdPtr; cmdPtr = cmdPtr->nextPtr) { - Tcl_CreateObjCommand(interp, cmdPtr->cmdName, cmdPtr->objProcPtr, - NULL, NULL); + Tcl_CreateObjCommand(interp, cmdPtr->cmdName, cmdPtr->objProcPtr, + NULL, NULL); #ifdef NS_AOLSERVER - Tcl_CreateObjCommand(interp, cmdPtr->cmdName2, cmdPtr->objProcPtr, - (void *)(size_t)cmdPtr->aolSpecial, NULL); + Tcl_CreateObjCommand(interp, cmdPtr->cmdName2, cmdPtr->objProcPtr, + (void *)(size_t)cmdPtr->aolSpecial, NULL); #endif } @@ -2283,39 +2283,39 @@ SvInit ( */ if (buckets == NULL) { - Tcl_MutexLock(&bucketsMutex); - if (buckets == NULL) { - buckets = (Bucket *)ckalloc(sizeof(Bucket) * NUMBUCKETS); - - for (i = 0; i < NUMBUCKETS; ++i) { - bucketPtr = &buckets[i]; - memset(bucketPtr, 0, sizeof(Bucket)); - Tcl_InitHashTable(&bucketPtr->arrays, TCL_STRING_KEYS); - Tcl_InitHashTable(&bucketPtr->handles, TCL_ONE_WORD_KEYS); - } - - /* - * There is no other way to get Sv_tclEmptyStringRep - * pointer value w/o this trick. - */ - - { - Tcl_Obj *dummy = Tcl_NewObj(); - Sv_tclEmptyStringRep = dummy->bytes; - Tcl_DecrRefCount(dummy); - } - - /* - * Register persistent store handlers - */ + Tcl_MutexLock(&bucketsMutex); + if (buckets == NULL) { + buckets = (Bucket *)ckalloc(sizeof(Bucket) * NUMBUCKETS); + + for (i = 0; i < NUMBUCKETS; ++i) { + bucketPtr = &buckets[i]; + memset(bucketPtr, 0, sizeof(Bucket)); + Tcl_InitHashTable(&bucketPtr->arrays, TCL_STRING_KEYS); + Tcl_InitHashTable(&bucketPtr->handles, TCL_ONE_WORD_KEYS); + } + + /* + * There is no other way to get Sv_tclEmptyStringRep + * pointer value w/o this trick. + */ + + { + Tcl_Obj *dummy = Tcl_NewObj(); + Sv_tclEmptyStringRep = dummy->bytes; + Tcl_DecrRefCount(dummy); + } + + /* + * Register persistent store handlers + */ #ifdef HAVE_GDBM - Sv_RegisterGdbmStore(); + Sv_RegisterGdbmStore(); #endif #ifdef HAVE_LMDB - Sv_RegisterLmdbStore(); + Sv_RegisterLmdbStore(); #endif - } - Tcl_MutexUnlock(&bucketsMutex); + } + Tcl_MutexUnlock(&bucketsMutex); } return NULL; @@ -2365,7 +2365,7 @@ SvFinalize ( Tcl_MutexLock(&nofThreadsMutex); if (nofThreads > 1) { - goto done; + goto done; } /* @@ -2373,31 +2373,31 @@ SvFinalize ( */ if (buckets != NULL) { - Tcl_MutexLock(&bucketsMutex); - if (buckets != NULL) { - for (i = 0; i < NUMBUCKETS; ++i) { - Bucket *bucketPtr = &buckets[i]; - hashPtr = Tcl_FirstHashEntry(&bucketPtr->arrays, &search); - while (hashPtr != NULL) { - Array *arrayPtr = (Array*)Tcl_GetHashValue(hashPtr); - UnlockArray(arrayPtr); - /* unbind array before delete (avoid flush of persistent storage) */ - UnbindArray(NULL, arrayPtr); - /* flush, delete etc. */ - DeleteArray(NULL, arrayPtr); - hashPtr = Tcl_NextHashEntry(&search); - } - if (bucketPtr->lock) { - Sp_RecursiveMutexFinalize(&bucketPtr->lock); - } - SvFinalizeContainers(bucketPtr); - Tcl_DeleteHashTable(&bucketPtr->handles); - Tcl_DeleteHashTable(&bucketPtr->arrays); - } - ckfree((char *)buckets), buckets = NULL; - } - buckets = NULL; - Tcl_MutexUnlock(&bucketsMutex); + Tcl_MutexLock(&bucketsMutex); + if (buckets != NULL) { + for (i = 0; i < NUMBUCKETS; ++i) { + Bucket *bucketPtr = &buckets[i]; + hashPtr = Tcl_FirstHashEntry(&bucketPtr->arrays, &search); + while (hashPtr != NULL) { + Array *arrayPtr = (Array*)Tcl_GetHashValue(hashPtr); + UnlockArray(arrayPtr); + /* unbind array before delete (avoid flush of persistent storage) */ + UnbindArray(NULL, arrayPtr); + /* flush, delete etc. */ + DeleteArray(NULL, arrayPtr); + hashPtr = Tcl_NextHashEntry(&search); + } + if (bucketPtr->lock) { + Sp_RecursiveMutexFinalize(&bucketPtr->lock); + } + SvFinalizeContainers(bucketPtr); + Tcl_DeleteHashTable(&bucketPtr->handles); + Tcl_DeleteHashTable(&bucketPtr->arrays); + } + ckfree((char *)buckets), buckets = NULL; + } + buckets = NULL; + Tcl_MutexUnlock(&bucketsMutex); } Tcl_MutexLock(&svMutex); @@ -2407,13 +2407,13 @@ SvFinalize ( */ if (svCmdInfo != NULL) { - cmdPtr = svCmdInfo; - while (cmdPtr) { - SvCmdInfo *tmpPtr = cmdPtr->nextPtr; - ckfree((char *)cmdPtr); - cmdPtr = tmpPtr; - } - svCmdInfo = NULL; + cmdPtr = svCmdInfo; + while (cmdPtr) { + SvCmdInfo *tmpPtr = cmdPtr->nextPtr; + ckfree((char *)cmdPtr); + cmdPtr = tmpPtr; + } + svCmdInfo = NULL; } /* @@ -2421,13 +2421,13 @@ SvFinalize ( */ if (regType != NULL) { - regPtr = regType; - while (regPtr) { - RegType *tmpPtr = regPtr->nextPtr; - ckfree((char *)regPtr); - regPtr = tmpPtr; - } - regType = NULL; + regPtr = regType; + while (regPtr) { + RegType *tmpPtr = regPtr->nextPtr; + ckfree((char *)regPtr); + regPtr = tmpPtr; + } + regType = NULL; } Tcl_MutexUnlock(&svMutex); diff --git a/generic/threadSvKeylistCmd.c b/generic/threadSvKeylistCmd.c index eb16b27..8ac0d99 100644 --- a/generic/threadSvKeylistCmd.c +++ b/generic/threadSvKeylistCmd.c @@ -55,16 +55,16 @@ Sv_RegisterKeylistCommands(void) static int initialized; if (initialized == 0) { - Tcl_MutexLock(&initMutex); - if (initialized == 0) { - Sv_RegisterCommand("keylset", SvKeylsetObjCmd, NULL, 0); - Sv_RegisterCommand("keylget", SvKeylgetObjCmd, NULL, 0); - Sv_RegisterCommand("keyldel", SvKeyldelObjCmd, NULL, 0); - Sv_RegisterCommand("keylkeys", SvKeylkeysObjCmd, NULL, 0); - Sv_RegisterObjType(&keyedListType.objType, DupKeyedListInternalRepShared); - initialized = 1; - } - Tcl_MutexUnlock(&initMutex); + Tcl_MutexLock(&initMutex); + if (initialized == 0) { + Sv_RegisterCommand("keylset", SvKeylsetObjCmd, NULL, 0); + Sv_RegisterCommand("keylget", SvKeylgetObjCmd, NULL, 0); + Sv_RegisterCommand("keyldel", SvKeyldelObjCmd, NULL, 0); + Sv_RegisterCommand("keylkeys", SvKeylkeysObjCmd, NULL, 0); + Sv_RegisterObjType(&keyedListType.objType, DupKeyedListInternalRepShared); + initialized = 1; + } + Tcl_MutexUnlock(&initMutex); } } @@ -106,19 +106,19 @@ SvKeylsetObjCmd( flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR; ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg); if (ret != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } if ((objc - off) < 2 || ((objc - off) % 2)) { - Tcl_WrongNumArgs(interp, off, objv, "key value ?key value ...?"); - goto cmd_err; + Tcl_WrongNumArgs(interp, off, objv, "key value ?key value ...?"); + goto cmd_err; } for (i = off; i < objc; i += 2) { - key = Tcl_GetString(objv[i]); - val = Sv_DuplicateObj(objv[i+1]); - ret = TclX_KeyedListSet(interp, svObj->tclObj, key, val); - if (ret != TCL_OK) { - goto cmd_err; - } + key = Tcl_GetString(objv[i]); + val = Sv_DuplicateObj(objv[i+1]); + ret = TclX_KeyedListSet(interp, svObj->tclObj, key, val); + if (ret != TCL_OK) { + goto cmd_err; + } } return Sv_PutContainer(interp, svObj, SV_CHANGED); @@ -165,48 +165,48 @@ SvKeylgetObjCmd( flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR; ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg); if (ret != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } if ((objc - off) > 2) { - Tcl_WrongNumArgs(interp, off, objv, "?key? ?var?"); - goto cmd_err; + Tcl_WrongNumArgs(interp, off, objv, "?key? ?var?"); + goto cmd_err; } if ((objc - off) == 0) { - if (Sv_PutContainer(interp, svObj, SV_UNCHANGED) != TCL_OK) { - return TCL_ERROR; - } - return SvKeylkeysObjCmd(arg, interp, objc, objv); + if (Sv_PutContainer(interp, svObj, SV_UNCHANGED) != TCL_OK) { + return TCL_ERROR; + } + return SvKeylkeysObjCmd(arg, interp, objc, objv); } if ((objc - off) == 2) { - varObjPtr = objv[off+1]; + varObjPtr = objv[off+1]; } else { - varObjPtr = NULL; + varObjPtr = NULL; } key = Tcl_GetString(objv[off]); ret = TclX_KeyedListGet(interp, svObj->tclObj, key, &valObjPtr); if (ret == TCL_ERROR) { - goto cmd_err; + goto cmd_err; } if (ret == TCL_BREAK) { - if (varObjPtr) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); - } else { - Tcl_AppendResult (interp, "key \"", key, "\" not found", (void *)NULL); - goto cmd_err; - } + if (varObjPtr) { + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + } else { + Tcl_AppendResult (interp, "key \"", key, "\" not found", (void *)NULL); + goto cmd_err; + } } else { - Tcl_Obj *resObjPtr = Sv_DuplicateObj(valObjPtr); - if (varObjPtr) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); - Tcl_GetString(varObjPtr); - if (varObjPtr->length) { - Tcl_ObjSetVar2(interp, varObjPtr, NULL, resObjPtr, 0); - } - } else { - Tcl_SetObjResult(interp, resObjPtr); - } + Tcl_Obj *resObjPtr = Sv_DuplicateObj(valObjPtr); + if (varObjPtr) { + Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); + Tcl_GetString(varObjPtr); + if (varObjPtr->length) { + Tcl_ObjSetVar2(interp, varObjPtr, NULL, resObjPtr, 0); + } + } else { + Tcl_SetObjResult(interp, resObjPtr); + } } return Sv_PutContainer(interp, svObj, SV_UNCHANGED); @@ -251,21 +251,21 @@ SvKeyldelObjCmd( ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); if (ret != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } if ((objc - off) < 1) { - Tcl_WrongNumArgs(interp, off, objv, "key ?key ...?"); - goto cmd_err; + Tcl_WrongNumArgs(interp, off, objv, "key ?key ...?"); + goto cmd_err; } for (i = off; i < objc; i++) { - key = Tcl_GetString(objv[i]); - ret = TclX_KeyedListDelete(interp, svObj->tclObj, key); - if (ret == TCL_BREAK) { - Tcl_AppendResult(interp, "key \"", key, "\" not found", (void *)NULL); - } - if (ret == TCL_BREAK || ret == TCL_ERROR) { - goto cmd_err; - } + key = Tcl_GetString(objv[i]); + ret = TclX_KeyedListDelete(interp, svObj->tclObj, key); + if (ret == TCL_BREAK) { + Tcl_AppendResult(interp, "key \"", key, "\" not found", (void *)NULL); + } + if (ret == TCL_BREAK || ret == TCL_ERROR) { + goto cmd_err; + } } return Sv_PutContainer(interp, svObj, SV_CHANGED); @@ -311,23 +311,23 @@ SvKeylkeysObjCmd( ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); if (ret != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } if ((objc - off) > 1) { - Tcl_WrongNumArgs(interp, 1, objv, "?lkey?"); - goto cmd_err; + Tcl_WrongNumArgs(interp, 1, objv, "?lkey?"); + goto cmd_err; } if ((objc - off) == 1) { - key = Tcl_GetString(objv[off]); + key = Tcl_GetString(objv[off]); } ret = TclX_KeyedListGetKeys(interp, svObj->tclObj, key, &listObj); if (key && ret == TCL_BREAK) { - Tcl_AppendResult(interp, "key \"", key, "\" not found", (void *)NULL); + Tcl_AppendResult(interp, "key \"", key, "\" not found", (void *)NULL); } if (ret == TCL_BREAK || ret == TCL_ERROR) { - goto cmd_err; + goto cmd_err; } Tcl_SetObjResult (interp, listObj); /* listObj allocated by API !*/ diff --git a/generic/threadSvListCmd.c b/generic/threadSvListCmd.c index d7b43e1..f1fe492 100644 --- a/generic/threadSvListCmd.c +++ b/generic/threadSvListCmd.c @@ -953,7 +953,6 @@ SvLsetFlat( Tcl_Obj *pendingInvalidates[10]; /* Assumed max nesting depth */ Tcl_Obj **pendingInvalidatesPtr = pendingInvalidates; Tcl_Size numPendingInvalidates = 0; - /* * Determine whether the index arg designates a list diff --git a/lib/ttrace.tcl b/lib/ttrace.tcl index d248ea0..1207b33 100644 --- a/lib/ttrace.tcl +++ b/lib/ttrace.tcl @@ -46,30 +46,30 @@ namespace eval ttrace { # Setup some compatibility wrappers if {[info commands nsv_set] != ""} { - variable tvers 0 - variable mutex ns_mutex - variable elock [$mutex create traceepochmutex] - # Import the underlying API; faster than recomputing - interp alias {} [namespace current]::_array {} nsv_array - interp alias {} [namespace current]::_incr {} nsv_incr - interp alias {} [namespace current]::_lappend {} nsv_lappend - interp alias {} [namespace current]::_names {} nsv_names - interp alias {} [namespace current]::_set {} nsv_set - interp alias {} [namespace current]::_unset {} nsv_unset + variable tvers 0 + variable mutex ns_mutex + variable elock [$mutex create traceepochmutex] + # Import the underlying API; faster than recomputing + interp alias {} [namespace current]::_array {} nsv_array + interp alias {} [namespace current]::_incr {} nsv_incr + interp alias {} [namespace current]::_lappend {} nsv_lappend + interp alias {} [namespace current]::_names {} nsv_names + interp alias {} [namespace current]::_set {} nsv_set + interp alias {} [namespace current]::_unset {} nsv_unset } elseif {![catch { - variable tvers [package require thread] + variable tvers [package require thread] }]} { - variable mutex thread::mutex - variable elock [$mutex create] - # Import the underlying API; faster than recomputing - interp alias {} [namespace current]::_array {} tsv::array - interp alias {} [namespace current]::_incr {} tsv::incr - interp alias {} [namespace current]::_lappend {} tsv::lappend - interp alias {} [namespace current]::_names {} tsv::names - interp alias {} [namespace current]::_set {} tsv::set - interp alias {} [namespace current]::_unset {} tsv::unset + variable mutex thread::mutex + variable elock [$mutex create] + # Import the underlying API; faster than recomputing + interp alias {} [namespace current]::_array {} tsv::array + interp alias {} [namespace current]::_incr {} tsv::incr + interp alias {} [namespace current]::_lappend {} tsv::lappend + interp alias {} [namespace current]::_names {} tsv::names + interp alias {} [namespace current]::_set {} tsv::set + interp alias {} [namespace current]::_unset {} tsv::unset } else { - error "requires NaviServer/AOLserver or Tcl threading extension" + error "requires NaviServer/AOLserver or Tcl threading extension" } # Keep in sync with the thread package @@ -101,371 +101,371 @@ namespace eval ttrace { # Initialize ttrace shared state if {[_array exists ttrace] == 0} { - _set ttrace lastepoch $epoch - _set ttrace epochlist "" + _set ttrace lastepoch $epoch + _set ttrace epochlist "" } # Initially, allow creation of epochs set config(-doepochs) 1 proc eval {cmd args} { - enable - set code [catch {uplevel 1 [concat $cmd $args]} result] - disable - if {$code == 0} { - if {[llength [info commands ns_ictl]]} { - ns_ictl save [getscript] - } else { - thread::broadcast { - package require ttrace - ttrace::update - } - } - } - return -code $code \ - -errorinfo $::errorInfo -errorcode $::errorCode $result + enable + set code [catch {uplevel 1 [concat $cmd $args]} result] + disable + if {$code == 0} { + if {[llength [info commands ns_ictl]]} { + ns_ictl save [getscript] + } else { + thread::broadcast { + package require ttrace + ttrace::update + } + } + } + return -code $code \ + -errorinfo $::errorInfo -errorcode $::errorCode $result } proc config {args} { - variable config - if {[llength $args] == 0} { - array get config - } elseif {[llength $args] == 1} { - set opt [lindex $args 0] - set config($opt) - } else { - set opt [lindex $args 0] - set val [lindex $args 1] - set config($opt) $val - } + variable config + if {[llength $args] == 0} { + array get config + } elseif {[llength $args] == 1} { + set opt [lindex $args 0] + set config($opt) + } else { + set opt [lindex $args 0] + set val [lindex $args 1] + set config($opt) $val + } } proc enable {} { - variable config - variable tracers - variable enables - variable enabled - incr enabled 1 - if {$enabled > 1} { - return - } - if {$config(-doepochs) != 0} { - variable epoch [_newepoch] - } - set nsp [namespace current] - foreach enabler $enables { - enable::_$enabler - } - foreach trace $tracers { - if {[info commands $trace] != ""} { - trace add execution $trace leave ${nsp}::trace::_$trace - } - } + variable config + variable tracers + variable enables + variable enabled + incr enabled 1 + if {$enabled > 1} { + return + } + if {$config(-doepochs) != 0} { + variable epoch [_newepoch] + } + set nsp [namespace current] + foreach enabler $enables { + enable::_$enabler + } + foreach trace $tracers { + if {[info commands $trace] != ""} { + trace add execution $trace leave ${nsp}::trace::_$trace + } + } } proc disable {} { - variable enabled - variable tracers - variable disables - incr enabled -1 - if {$enabled > 0} { - return - } - set nsp [namespace current] - foreach disabler $disables { - disable::_$disabler - } - foreach trace $tracers { - if {[info commands $trace] != ""} { - trace remove execution $trace leave ${nsp}::trace::_$trace - } - } + variable enabled + variable tracers + variable disables + incr enabled -1 + if {$enabled > 0} { + return + } + set nsp [namespace current] + foreach disabler $disables { + disable::_$disabler + } + foreach trace $tracers { + if {[info commands $trace] != ""} { + trace remove execution $trace leave ${nsp}::trace::_$trace + } + } } proc isenabled {} { - variable enabled - expr {$enabled > 0} + variable enabled + expr {$enabled > 0} } proc update {{from -1}} { - if {$from < 0} { - variable epoch [_set ttrace lastepoch] - } else { - if {[lsearch [_set ttrace epochlist] $from] < 0} { - error "no such epoch: $from" - } - variable epoch $from - } - uplevel 1 [getscript] + if {$from < 0} { + variable epoch [_set ttrace lastepoch] + } else { + if {[lsearch [_set ttrace epochlist] $from] < 0} { + error "no such epoch: $from" + } + variable epoch $from + } + uplevel 1 [getscript] } proc getscript {} { - variable preloads - variable epoch - variable scripts - append script [_serializensp] \n - append script "::namespace eval [namespace current] {" \n - append script "::namespace export unknown" \n - append script "_useepoch $epoch" \n - append script "}" \n - foreach cmd $preloads { - append script [_serializeproc $cmd] \n - } - foreach maker $scripts { - append script [script::_$maker] - } - return $script + variable preloads + variable epoch + variable scripts + append script [_serializensp] \n + append script "::namespace eval [namespace current] {" \n + append script "::namespace export unknown" \n + append script "_useepoch $epoch" \n + append script "}" \n + foreach cmd $preloads { + append script [_serializeproc $cmd] \n + } + foreach maker $scripts { + append script [script::_$maker] + } + return $script } proc cleanup {args} { - foreach cmd [info commands resolve::cleaner_*] { - uplevel 1 $cmd $args - } + foreach cmd [info commands resolve::cleaner_*] { + uplevel 1 $cmd $args + } } proc preload {cmd} { - variable preloads - if {[lsearch $preloads $cmd] < 0} { - lappend preloads $cmd - } + variable preloads + if {[lsearch $preloads $cmd] < 0} { + lappend preloads $cmd + } } proc atenable {cmd arglist body} { - variable enables - if {[lsearch $enables $cmd] < 0} { - lappend enables $cmd - set cmd [namespace current]::enable::_$cmd - proc $cmd $arglist $body - return $cmd - } + variable enables + if {[lsearch $enables $cmd] < 0} { + lappend enables $cmd + set cmd [namespace current]::enable::_$cmd + proc $cmd $arglist $body + return $cmd + } } proc atdisable {cmd arglist body} { - variable disables - if {[lsearch $disables $cmd] < 0} { - lappend disables $cmd - set cmd [namespace current]::disable::_$cmd - proc $cmd $arglist $body - return $cmd - } + variable disables + if {[lsearch $disables $cmd] < 0} { + lappend disables $cmd + set cmd [namespace current]::disable::_$cmd + proc $cmd $arglist $body + return $cmd + } } proc addtrace {cmd arglist body} { - variable tracers - if {[lsearch $tracers $cmd] < 0} { - lappend tracers $cmd - set tracer [namespace current]::trace::_$cmd - proc $tracer $arglist $body - if {[isenabled]} { - trace add execution $cmd leave $tracer - } - return $tracer - } + variable tracers + if {[lsearch $tracers $cmd] < 0} { + lappend tracers $cmd + set tracer [namespace current]::trace::_$cmd + proc $tracer $arglist $body + if {[isenabled]} { + trace add execution $cmd leave $tracer + } + return $tracer + } } proc addscript {cmd body} { - variable scripts - if {[lsearch $scripts $cmd] < 0} { - lappend scripts $cmd - set cmd [namespace current]::script::_$cmd - proc $cmd args $body - return $cmd - } + variable scripts + if {[lsearch $scripts $cmd] < 0} { + lappend scripts $cmd + set cmd [namespace current]::script::_$cmd + proc $cmd args $body + return $cmd + } } proc addresolver {cmd arglist body} { - variable resolvers - if {[lsearch $resolvers $cmd] < 0} { - lappend resolvers $cmd - set cmd [namespace current]::resolve::$cmd - proc $cmd $arglist $body - return $cmd - } + variable resolvers + if {[lsearch $resolvers $cmd] < 0} { + lappend resolvers $cmd + set cmd [namespace current]::resolve::$cmd + proc $cmd $arglist $body + return $cmd + } } proc addcleanup {body} { - variable cleancnt - set cmd [namespace current]::resolve::cleaner_[incr cleancnt] - proc $cmd args $body - return $cmd + variable cleancnt + set cmd [namespace current]::resolve::cleaner_[incr cleancnt] + proc $cmd args $body + return $cmd } proc addentry {cmd var val} { - variable epoch - _set ${epoch}-$cmd $var $val + variable epoch + _set ${epoch}-$cmd $var $val } proc delentry {cmd var} { - variable epoch - set ei $::errorInfo - set ec $::errorCode - catch {_unset ${epoch}-$cmd $var} - set ::errorInfo $ei - set ::errorCode $ec + variable epoch + set ei $::errorInfo + set ec $::errorCode + catch {_unset ${epoch}-$cmd $var} + set ::errorInfo $ei + set ::errorCode $ec } proc getentry {cmd var} { - variable epoch - set ei $::errorInfo - set ec $::errorCode - if {[catch {_set ${epoch}-$cmd $var} val]} { - set ::errorInfo $ei - set ::errorCode $ec - set val "" - } - return $val + variable epoch + set ei $::errorInfo + set ec $::errorCode + if {[catch {_set ${epoch}-$cmd $var} val]} { + set ::errorInfo $ei + set ::errorCode $ec + set val "" + } + return $val } proc getentries {cmd {pattern *}} { - variable epoch - _array names ${epoch}-$cmd $pattern + variable epoch + _array names ${epoch}-$cmd $pattern } proc unknown {args} { - set cmd [lindex $args 0] - if {[uplevel 1 ttrace::_resolve [list $cmd]]} { - set c [catch {uplevel 1 $cmd [lrange $args 1 end]} r] - } else { - set c [catch {uplevel 1 ::tcl::unknown $args} r] - } - return -code $c -errorcode $::errorCode -errorinfo $::errorInfo $r + set cmd [lindex $args 0] + if {[uplevel 1 ttrace::_resolve [list $cmd]]} { + set c [catch {uplevel 1 $cmd [lrange $args 1 end]} r] + } else { + set c [catch {uplevel 1 ::tcl::unknown $args} r] + } + return -code $c -errorcode $::errorCode -errorinfo $::errorInfo $r } proc _resolve {cmd} { - variable resolvers - foreach resolver $resolvers { - if {[uplevel 1 [info comm resolve::$resolver] [list $cmd]]} { - return 1 - } - } - return 0 + variable resolvers + foreach resolver $resolvers { + if {[uplevel 1 [info comm resolve::$resolver] [list $cmd]]} { + return 1 + } + } + return 0 } proc _getthread {} { - if {[info commands ns_thread] == ""} { - thread::id - } else { - ns_thread getid - } + if {[info commands ns_thread] == ""} { + thread::id + } else { + ns_thread getid + } } proc _getthreads {} { - if {[info commands ns_thread] == ""} { - return [thread::names] - } else { - foreach entry [ns_info threads] { - lappend threads [lindex $entry 2] - } - return $threads - } + if {[info commands ns_thread] == ""} { + return [thread::names] + } else { + foreach entry [ns_info threads] { + lappend threads [lindex $entry 2] + } + return $threads + } } proc _newepoch {} { - variable elock - variable mutex - $mutex lock $elock - set old [_set ttrace lastepoch] - set new [_incr ttrace lastepoch] - _lappend ttrace $new [_getthread] - if {$old >= 0} { - _copyepoch $old $new - _delepochs - } - _lappend ttrace epochlist $new - $mutex unlock $elock - return $new + variable elock + variable mutex + $mutex lock $elock + set old [_set ttrace lastepoch] + set new [_incr ttrace lastepoch] + _lappend ttrace $new [_getthread] + if {$old >= 0} { + _copyepoch $old $new + _delepochs + } + _lappend ttrace epochlist $new + $mutex unlock $elock + return $new } proc _copyepoch {old new} { - foreach var [_names $old-*] { - set cmd [lindex [split $var -] 1] - _array reset $new-$cmd [_array get $var] - } + foreach var [_names $old-*] { + set cmd [lindex [split $var -] 1] + _array reset $new-$cmd [_array get $var] + } } proc _delepochs {} { - set tlist [_getthreads] - set elist "" - foreach epoch [_set ttrace epochlist] { - if {[_dropepoch $epoch $tlist] == 0} { - lappend elist $epoch - } else { - _unset ttrace $epoch - } - } - _set ttrace epochlist $elist + set tlist [_getthreads] + set elist "" + foreach epoch [_set ttrace epochlist] { + if {[_dropepoch $epoch $tlist] == 0} { + lappend elist $epoch + } else { + _unset ttrace $epoch + } + } + _set ttrace epochlist $elist } proc _dropepoch {epoch threads} { - set self [_getthread] - foreach tid [_set ttrace $epoch] { - if {$tid != $self && [lsearch $threads $tid] >= 0} { - lappend alive $tid - } - } - if {[info exists alive]} { - _set ttrace $epoch $alive - return 0 - } else { - foreach var [_names $epoch-*] { - _unset $var - } - return 1 - } + set self [_getthread] + foreach tid [_set ttrace $epoch] { + if {$tid != $self && [lsearch $threads $tid] >= 0} { + lappend alive $tid + } + } + if {[info exists alive]} { + _set ttrace $epoch $alive + return 0 + } else { + foreach var [_names $epoch-*] { + _unset $var + } + return 1 + } } proc _useepoch {epoch} { - if {$epoch >= 0} { - set tid [_getthread] - if {[lsearch [_set ttrace $epoch] $tid] == -1} { - _lappend ttrace $epoch $tid - } - } + if {$epoch >= 0} { + set tid [_getthread] + if {[lsearch [_set ttrace $epoch] $tid] == -1} { + _lappend ttrace $epoch $tid + } + } } proc _serializeproc {cmd} { - set dargs [info args $cmd] - set pbody [info body $cmd] - set pargs "" - foreach arg $dargs { - if {![info default $cmd $arg def]} { - lappend pargs $arg - } else { - lappend pargs [list $arg $def] - } - } - set nsp [namespace qual $cmd] - if {$nsp == ""} { - set nsp "::" - } - append res [list ::namespace eval $nsp] " {" \n - append res [list ::proc [namespace tail $cmd] $pargs $pbody] \n - append res "}" \n + set dargs [info args $cmd] + set pbody [info body $cmd] + set pargs "" + foreach arg $dargs { + if {![info default $cmd $arg def]} { + lappend pargs $arg + } else { + lappend pargs [list $arg $def] + } + } + set nsp [namespace qual $cmd] + if {$nsp == ""} { + set nsp "::" + } + append res [list ::namespace eval $nsp] " {" \n + append res [list ::proc [namespace tail $cmd] $pargs $pbody] \n + append res "}" \n } proc _serializensp {{nsp ""} {result _}} { - upvar $result res - if {$nsp == ""} { - set nsp [namespace current] - } - append res [list ::namespace eval $nsp] " {" \n - foreach var [info vars ${nsp}::*] { - set vname [namespace tail $var] - if {[array exists $var] == 0} { - append res [list ::variable $vname [set $var]] \n - } else { - append res [list ::variable $vname] \n - append res [list ::array set $vname [array get $var]] \n - } - } - foreach cmd [info procs ${nsp}::*] { - append res [_serializeproc $cmd] \n - } - append res "}" \n - foreach nn [namespace children $nsp] { - _serializensp $nn res - } - return $res + upvar $result res + if {$nsp == ""} { + set nsp [namespace current] + } + append res [list ::namespace eval $nsp] " {" \n + foreach var [info vars ${nsp}::*] { + set vname [namespace tail $var] + if {[array exists $var] == 0} { + append res [list ::variable $vname [set $var]] \n + } else { + append res [list ::variable $vname] \n + append res [list ::array set $vname [array get $var]] \n + } + } + foreach cmd [info procs ${nsp}::*] { + append res [_serializeproc $cmd] \n + } + append res "}" \n + foreach nn [namespace children $nsp] { + _serializensp $nn res + } + return $res } } @@ -497,28 +497,28 @@ eval { # ttrace::addtrace load {cmdline code args} { - if {$code != 0} { - return - } - set image [lindex $cmdline 1] - set initp [lindex $cmdline 2] - if {$initp == ""} { - foreach pkg [info loaded] { - if {[lindex $pkg 0] == $image} { - set initp [lindex $pkg 1] - } - } - } - ttrace::addentry load $image $initp + if {$code != 0} { + return + } + set image [lindex $cmdline 1] + set initp [lindex $cmdline 2] + if {$initp == ""} { + foreach pkg [info loaded] { + if {[lindex $pkg 0] == $image} { + set initp [lindex $pkg 1] + } + } + } + ttrace::addentry load $image $initp } ttrace::addscript load { - append res "\n" - foreach entry [ttrace::getentries load] { - set initp [ttrace::getentry load $entry] - append res "::load {} $initp" \n - } - return $res + append res "\n" + foreach entry [ttrace::getentries load] { + set initp [ttrace::getentry load $entry] + append res "::load {} $initp" \n + } + return $res } # @@ -539,62 +539,62 @@ eval { # ttrace::addtrace namespace {cmdline code args} { - if {$code != 0} { - return - } - set nop [lindex $cmdline 1] - set cns [uplevel 1 namespace current] - if {$cns == "::"} { - set cns "" - } - switch -glob $nop { - eva* { - set nsp [lindex $cmdline 2] - if {![string match "::*" $nsp]} { - set nsp ${cns}::$nsp - } - ttrace::addentry namespace $nsp 1 - } - imp* { - # - parse import arguments (skip opt "-force") - set opts [lrange $cmdline 2 end] - if {[string match "-fo*" [lindex $opts 0]]} { - set opts [lrange $cmdline 3 end] - } - # - register all imported procs and commands - foreach opt $opts { - if {![string match "::*" [::namespace qual $opt]]} { - set opt ${cns}::$opt - } - # - first import procs - foreach entry [ttrace::getentries proc $opt] { - set cmd ${cns}::[::namespace tail $entry] - set nsp [::namespace qual $entry] - set done($cmd) 1 - set entry [list 0 $nsp "" ""] - ttrace::addentry proc $cmd $entry - } - - # - then import commands - foreach entry [info commands $opt] { - set cmd ${cns}::[::namespace tail $entry] - set nsp [::namespace qual $entry] - if {[info exists done($cmd)] == 0} { - set entry [list 0 $nsp "" ""] - ttrace::addentry proc $cmd $entry - } - } - } - } - } + if {$code != 0} { + return + } + set nop [lindex $cmdline 1] + set cns [uplevel 1 namespace current] + if {$cns == "::"} { + set cns "" + } + switch -glob $nop { + eva* { + set nsp [lindex $cmdline 2] + if {![string match "::*" $nsp]} { + set nsp ${cns}::$nsp + } + ttrace::addentry namespace $nsp 1 + } + imp* { + # - parse import arguments (skip opt "-force") + set opts [lrange $cmdline 2 end] + if {[string match "-fo*" [lindex $opts 0]]} { + set opts [lrange $cmdline 3 end] + } + # - register all imported procs and commands + foreach opt $opts { + if {![string match "::*" [::namespace qual $opt]]} { + set opt ${cns}::$opt + } + # - first import procs + foreach entry [ttrace::getentries proc $opt] { + set cmd ${cns}::[::namespace tail $entry] + set nsp [::namespace qual $entry] + set done($cmd) 1 + set entry [list 0 $nsp "" ""] + ttrace::addentry proc $cmd $entry + } + + # - then import commands + foreach entry [info commands $opt] { + set cmd ${cns}::[::namespace tail $entry] + set nsp [::namespace qual $entry] + if {[info exists done($cmd)] == 0} { + set entry [list 0 $nsp "" ""] + ttrace::addentry proc $cmd $entry + } + } + } + } + } } ttrace::addscript namespace { - append res \n - foreach entry [ttrace::getentries namespace] { - append res "::namespace eval $entry {}" \n - } - return $res + append res \n + foreach entry [ttrace::getentries namespace] { + append res "::namespace eval $entry {}" \n + } + return $res } # @@ -610,41 +610,41 @@ eval { # ttrace::addtrace variable {cmdline code args} { - if {$code != 0} { - return - } - set opts [lrange $cmdline 1 end] - if {[llength $opts]} { - set cns [uplevel 1 namespace current] - if {$cns == "::"} { - set cns "" - } - foreach {var val} $opts { - if {![string match "::*" $var]} { - set var ${cns}::$var - } - ttrace::addentry variable $var 1 - } - } + if {$code != 0} { + return + } + set opts [lrange $cmdline 1 end] + if {[llength $opts]} { + set cns [uplevel 1 namespace current] + if {$cns == "::"} { + set cns "" + } + foreach {var val} $opts { + if {![string match "::*" $var]} { + set var ${cns}::$var + } + ttrace::addentry variable $var 1 + } + } } ttrace::addscript variable { - append res \n - foreach entry [ttrace::getentries variable] { - set cns [namespace qual $entry] - set var [namespace tail $entry] - append res "::namespace eval $cns {" \n - append res "::variable $var" - if {[array exists $entry]} { - append res "\n::array set $var [list [array get $entry]]" \n - } elseif {[info exists $entry]} { - append res " [list [set $entry]]" \n - } else { - append res \n - } - append res "}" \n - } - return $res + append res \n + foreach entry [ttrace::getentries variable] { + set cns [namespace qual $entry] + set var [namespace tail $entry] + append res "::namespace eval $cns {" \n + append res "::variable $var" + if {[array exists $entry]} { + append res "\n::array set $var [list [array get $entry]]" \n + } elseif {[info exists $entry]} { + append res " [list [set $entry]]" \n + } else { + append res \n + } + append res "}" \n + } + return $res } @@ -660,35 +660,35 @@ eval { # ttrace::addtrace rename {cmdline code args} { - if {$code != 0} { - return - } - set cns [uplevel 1 namespace current] - if {$cns == "::"} { - set cns "" - } - set old [lindex $cmdline 1] - if {![string match "::*" $old]} { - set old ${cns}::$old - } - set new [lindex $cmdline 2] - if {$new != ""} { - if {![string match "::*" $new]} { - set new ${cns}::$new - } - ttrace::addentry rename $old $new - } else { - ttrace::delentry proc $old - } + if {$code != 0} { + return + } + set cns [uplevel 1 namespace current] + if {$cns == "::"} { + set cns "" + } + set old [lindex $cmdline 1] + if {![string match "::*" $old]} { + set old ${cns}::$old + } + set new [lindex $cmdline 2] + if {$new != ""} { + if {![string match "::*" $new]} { + set new ${cns}::$new + } + ttrace::addentry rename $old $new + } else { + ttrace::delentry proc $old + } } ttrace::addscript rename { - append res \n - foreach old [ttrace::getentries rename] { - set new [ttrace::getentry rename $old] - append res "::rename $old {$new}" \n - } - return $res + append res \n + foreach old [ttrace::getentries rename] { + set new [ttrace::getentry rename $old] + append res "::rename $old {$new}" \n + } + return $res } # @@ -705,82 +705,82 @@ eval { # ttrace::addtrace proc {cmdline code args} { - if {$code != 0} { - return - } - set cns [uplevel 1 namespace current] - if {$cns == "::"} { - set cns "" - } - set cmd [lindex $cmdline 1] - if {![string match "::*" $cmd]} { - set cmd ${cns}::$cmd - } - set dargs [info args $cmd] - set pbody [info body $cmd] - set pargs "" - foreach arg $dargs { - if {![info default $cmd $arg def]} { - lappend pargs $arg - } else { - lappend pargs [list $arg $def] - } - } - set pdef [ttrace::getentry proc $cmd] - if {$pdef == ""} { - set epoch -1 ; # never traced before - } else { - set epoch [lindex $pdef 0] - } - ttrace::addentry proc $cmd [list [incr epoch] "" $pargs $pbody] + if {$code != 0} { + return + } + set cns [uplevel 1 namespace current] + if {$cns == "::"} { + set cns "" + } + set cmd [lindex $cmdline 1] + if {![string match "::*" $cmd]} { + set cmd ${cns}::$cmd + } + set dargs [info args $cmd] + set pbody [info body $cmd] + set pargs "" + foreach arg $dargs { + if {![info default $cmd $arg def]} { + lappend pargs $arg + } else { + lappend pargs [list $arg $def] + } + } + set pdef [ttrace::getentry proc $cmd] + if {$pdef == ""} { + set epoch -1 ; # never traced before + } else { + set epoch [lindex $pdef 0] + } + ttrace::addentry proc $cmd [list [incr epoch] "" $pargs $pbody] } ttrace::addscript proc { - return { - if {[info command ::tcl::unknown] == ""} { - rename ::unknown ::tcl::unknown - namespace import -force ::ttrace::unknown - } - if {[info command ::tcl::info] == ""} { - rename ::info ::tcl::info - } - proc ::info args { - set cmd [lindex $args 0] - set hit [lsearch -glob {commands procs args default body} $cmd*] - if {$hit > 1} { - if {[catch {uplevel 1 ::tcl::info $args}]} { - uplevel 1 ttrace::_resolve [list [lindex $args 1]] - } - return [uplevel 1 ::tcl::info $args] - } - if {$hit == -1} { - return [uplevel 1 ::tcl::info $args] - } - set cns [uplevel 1 namespace current] - if {$cns == "::"} { - set cns "" - } - set pat [lindex $args 1] - if {![string match "::*" $pat]} { - set pat ${cns}::$pat - } - set fns [ttrace::getentries proc $pat] - if {[string match $cmd* commands]} { - set fns [concat $fns [ttrace::getentries xotcl $pat]] - } - foreach entry $fns { - if {$cns != [namespace qual $entry]} { - set lazy($entry) 1 - } else { - set lazy([namespace tail $entry]) 1 - } - } - foreach entry [uplevel 1 ::tcl::info $args] { - set lazy($entry) 1 - } - array names lazy - } - } + return { + if {[info command ::tcl::unknown] == ""} { + rename ::unknown ::tcl::unknown + namespace import -force ::ttrace::unknown + } + if {[info command ::tcl::info] == ""} { + rename ::info ::tcl::info + } + proc ::info args { + set cmd [lindex $args 0] + set hit [lsearch -glob {commands procs args default body} $cmd*] + if {$hit > 1} { + if {[catch {uplevel 1 ::tcl::info $args}]} { + uplevel 1 ttrace::_resolve [list [lindex $args 1]] + } + return [uplevel 1 ::tcl::info $args] + } + if {$hit == -1} { + return [uplevel 1 ::tcl::info $args] + } + set cns [uplevel 1 namespace current] + if {$cns == "::"} { + set cns "" + } + set pat [lindex $args 1] + if {![string match "::*" $pat]} { + set pat ${cns}::$pat + } + set fns [ttrace::getentries proc $pat] + if {[string match $cmd* commands]} { + set fns [concat $fns [ttrace::getentries xotcl $pat]] + } + foreach entry $fns { + if {$cns != [namespace qual $entry]} { + set lazy($entry) 1 + } else { + set lazy([namespace tail $entry]) 1 + } + } + foreach entry [uplevel 1 ::tcl::info $args] { + set lazy($entry) 1 + } + array names lazy + } + } } # @@ -790,53 +790,53 @@ eval { # ttrace::addresolver resolveprocs {cmd {export 0}} { - set cns [uplevel 1 namespace current] - set name [namespace tail $cmd] - if {$cns == "::"} { - set cns "" - } - if {![string match "::*" $cmd]} { - set ncmd ${cns}::$cmd - set gcmd ::$cmd - } else { - set ncmd $cmd - set gcmd $cmd - } - set pdef [ttrace::getentry proc $ncmd] - if {$pdef == ""} { - set pdef [ttrace::getentry proc $gcmd] - if {$pdef == ""} { - return 0 - } - set cmd $gcmd - } else { - set cmd $ncmd - } - set epoch [lindex $pdef 0] - set pnsp [lindex $pdef 1] - if {$pnsp != ""} { - set nsp [namespace qual $cmd] - if {$nsp == ""} { - set nsp :: - } - set cmd ${pnsp}::$name - if {[resolveprocs $cmd 1] == 0 && [info commands $cmd] == ""} { - return 0 - } - namespace eval $nsp "namespace import -force $cmd" - } else { - uplevel 0 [list ::proc $cmd [lindex $pdef 2] [lindex $pdef 3]] - if {$export} { - set nsp [namespace qual $cmd] - if {$nsp == ""} { - set nsp :: - } - namespace eval $nsp "namespace export $name" - } - } - variable resolveproc - set resolveproc($cmd) $epoch - return 1 + set cns [uplevel 1 namespace current] + set name [namespace tail $cmd] + if {$cns == "::"} { + set cns "" + } + if {![string match "::*" $cmd]} { + set ncmd ${cns}::$cmd + set gcmd ::$cmd + } else { + set ncmd $cmd + set gcmd $cmd + } + set pdef [ttrace::getentry proc $ncmd] + if {$pdef == ""} { + set pdef [ttrace::getentry proc $gcmd] + if {$pdef == ""} { + return 0 + } + set cmd $gcmd + } else { + set cmd $ncmd + } + set epoch [lindex $pdef 0] + set pnsp [lindex $pdef 1] + if {$pnsp != ""} { + set nsp [namespace qual $cmd] + if {$nsp == ""} { + set nsp :: + } + set cmd ${pnsp}::$name + if {[resolveprocs $cmd 1] == 0 && [info commands $cmd] == ""} { + return 0 + } + namespace eval $nsp "namespace import -force $cmd" + } else { + uplevel 0 [list ::proc $cmd [lindex $pdef 2] [lindex $pdef 3]] + if {$export} { + set nsp [namespace qual $cmd] + if {$nsp == ""} { + set nsp :: + } + namespace eval $nsp "namespace export $name" + } + } + variable resolveproc + set resolveproc($cmd) $epoch + return 1 } # @@ -855,61 +855,61 @@ eval { # ttrace::atenable XOTclEnabler {args} { - if {[info commands ::xotcl::Class] == ""} { - return - } - if {[info commands ::xotcl::_creator] == ""} { - ::xotcl::Class create ::xotcl::_creator -instproc create {args} { - set result [next] - if {![string match ::xotcl::_* $result]} { - ttrace::addentry xotcl $result "" - } - return $result - } - } - ::xotcl::Class instmixin ::xotcl::_creator + if {[info commands ::xotcl::Class] == ""} { + return + } + if {[info commands ::xotcl::_creator] == ""} { + ::xotcl::Class create ::xotcl::_creator -instproc create {args} { + set result [next] + if {![string match ::xotcl::_* $result]} { + ttrace::addentry xotcl $result "" + } + return $result + } + } + ::xotcl::Class instmixin ::xotcl::_creator } ttrace::atdisable XOTclDisabler {args} { - if { [info commands ::xotcl::Class] == "" - || [info commands ::xotcl::_creator] == ""} { - return - } - ::xotcl::Class instmixin "" - ::xotcl::_creator destroy + if { [info commands ::xotcl::Class] == "" + || [info commands ::xotcl::_creator] == ""} { + return + } + ::xotcl::Class instmixin "" + ::xotcl::_creator destroy } set resolver [ttrace::addresolver resolveclasses {classname} { - set cns [uplevel 1 namespace current] - set script [ttrace::getentry xotcl $classname] - if {$script == ""} { - set name [namespace tail $classname] - if {$cns == "::"} { - set script [ttrace::getentry xotcl ::$name] - } else { - set script [ttrace::getentry xotcl ${cns}::$name] - if {$script == ""} { - set script [ttrace::getentry xotcl ::$name] - } - } - if {$script == ""} { - return 0 - } - } - uplevel 1 [list namespace eval $cns $script] - return 1 + set cns [uplevel 1 namespace current] + set script [ttrace::getentry xotcl $classname] + if {$script == ""} { + set name [namespace tail $classname] + if {$cns == "::"} { + set script [ttrace::getentry xotcl ::$name] + } else { + set script [ttrace::getentry xotcl ${cns}::$name] + if {$script == ""} { + set script [ttrace::getentry xotcl ::$name] + } + } + if {$script == ""} { + return 0 + } + } + uplevel 1 [list namespace eval $cns $script] + return 1 }] ttrace::addscript xotcl [subst -nocommands { - if {![catch {Serializer new} ss]} { - foreach entry [ttrace::getentries xotcl] { - if {[ttrace::getentry xotcl \$entry] == ""} { - ttrace::addentry xotcl \$entry [\$ss serialize \$entry] - } - } - \$ss destroy - return {::xotcl::Class proc __unknown name {$resolver \$name}} - } + if {![catch {Serializer new} ss]} { + foreach entry [ttrace::getentries xotcl] { + if {[ttrace::getentry xotcl \$entry] == ""} { + ttrace::addentry xotcl \$entry [\$ss serialize \$entry] + } + } + \$ss destroy + return {::xotcl::Class proc __unknown name {$resolver \$name}} + } }] # @@ -918,17 +918,17 @@ eval { # ttrace::addcleanup { - variable resolveproc - foreach cmd [array names resolveproc] { - set def [ttrace::getentry proc $cmd] - if {$def != ""} { - set new [lindex $def 0] - set old $resolveproc($cmd) - if {[info command $cmd] != "" && $new != $old} { - catch {rename $cmd ""} - } - } - } + variable resolveproc + foreach cmd [array names resolveproc] { + set def [ttrace::getentry proc $cmd] + if {$def != ""} { + set new [lindex $def 0] + set old $resolveproc($cmd) + if {[info command $cmd] != "" && $new != $old} { + catch {rename $cmd ""} + } + } + } } } diff --git a/naviserver.m4 b/naviserver.m4 index f0ab1fc..430a83f 100644 --- a/naviserver.m4 +++ b/naviserver.m4 @@ -31,26 +31,26 @@ AC_DEFUN(NS_PATH_AOLSERVER, [ AC_CACHE_VAL(ac_cv_c_naviserver,[ if test x"${with_naviserver}" != x ; then - if test -f "${with_naviserver}/include/ns.h" ; then - ac_cv_c_naviserver=`(cd ${with_naviserver}; pwd)` - else - AC_MSG_ERROR([${with_naviserver} directory doesn't contain ns.h]) - fi + if test -f "${with_naviserver}/include/ns.h" ; then + ac_cv_c_naviserver=`(cd ${with_naviserver}; pwd)` + else + AC_MSG_ERROR([${with_naviserver} directory doesn't contain ns.h]) + fi fi ]) if test x"${ac_cv_c_naviserver}" = x ; then - AC_MSG_RESULT([none found]) + AC_MSG_RESULT([none found]) else - NS_DIR=${ac_cv_c_naviserver} - AC_MSG_RESULT([found NaviServer/AOLserver in $NS_DIR]) - NS_INCLUDES="-I\"${NS_DIR}/include\"" - if test "`uname -s`" = Darwin ; then - aollibs=`ls ${NS_DIR}/lib/libns* 2>/dev/null` - if test x"$aollibs" != x ; then - NS_LIBS="-L\"${NS_DIR}/lib\" -lnsd -lnsthread" - fi - fi - AC_DEFINE(NS_AOLSERVER) + NS_DIR=${ac_cv_c_naviserver} + AC_MSG_RESULT([found NaviServer/AOLserver in $NS_DIR]) + NS_INCLUDES="-I\"${NS_DIR}/include\"" + if test "`uname -s`" = Darwin ; then + aollibs=`ls ${NS_DIR}/lib/libns* 2>/dev/null` + if test x"$aollibs" != x ; then + NS_LIBS="-L\"${NS_DIR}/lib\" -lnsd -lnsthread" + fi + fi + AC_DEFINE(NS_AOLSERVER) fi ]) diff --git a/tcl/README b/tcl/README index d930d6f..26f3aa8 100644 --- a/tcl/README +++ b/tcl/README @@ -5,24 +5,24 @@ things and applications using the Tcl threading extension. Currently, following packages are supplied: tpool/ Example Tcl-only implementation of thread pools. - The threading extension includes an efficient - threadpool implementation in C. This file is - provided as a fully functional example on how this - functionality could be implemented in Tcl alone. + The threading extension includes an efficient + threadpool implementation in C. This file is + provided as a fully functional example on how this + functionality could be implemented in Tcl alone. phttpd/ MT-enabled httpd server. It uses threadpool to - distribute incoming requests among several worker - threads in the threadpool. This way blocking - requests may be handled much better, w/o halting - the event loop of the main responder thread. - In this directory you will also find the uhttpd. - This is the same web-server but operating in the - event-loop mode alone, no threadpool support. - This is good for comparison purposes. + distribute incoming requests among several worker + threads in the threadpool. This way blocking + requests may be handled much better, w/o halting + the event loop of the main responder thread. + In this directory you will also find the uhttpd. + This is the same web-server but operating in the + event-loop mode alone, no threadpool support. + This is good for comparison purposes. cmdsrv/ Socket command-line server. Each new connection - gets new thread, thus allowing multiple outstanding - blocking calls without halting the event loop. + gets new thread, thus allowing multiple outstanding + blocking calls without halting the event loop. To play around with above packages, change to the corresponding directory and source files in the Tcl8.5 (or later) Tcl shell. diff --git a/tcl/cmdsrv/cmdsrv.tcl b/tcl/cmdsrv/cmdsrv.tcl index de4694d..4141ad5 100644 --- a/tcl/cmdsrv/cmdsrv.tcl +++ b/tcl/cmdsrv/cmdsrv.tcl @@ -55,7 +55,7 @@ proc cmdsrv::create {port args} { variable data if {[llength $args] % 2} { - error "wrong \# arguments, should be: key1 val1 key2 val2..." + error "wrong \# arguments, should be: key1 val1 key2 val2..." } # @@ -63,8 +63,8 @@ proc cmdsrv::create {port args} { # array set data { - -idletime 300000 - -initcmd {source -encoding utf-8 cmdsrv.tcl} + -idletime 300000 + -initcmd {source -encoding utf-8 cmdsrv.tcl} } # @@ -72,13 +72,13 @@ proc cmdsrv::create {port args} { # foreach {arg val} $args { - switch -- $arg { - -idletime {set data($arg) [expr {$val*1000}]} - -initcmd {append data($arg) \n $val} - default { - error "unsupported pool option \"$arg\"" - } - } + switch -- $arg { + -idletime {set data($arg) [expr {$val*1000}]} + -initcmd {append data($arg) \n $val} + default { + error "unsupported pool option \"$arg\"" + } + } } # @@ -158,10 +158,10 @@ proc cmdsrv::Accept {s ipaddr port} { # thread::send -async $tid [subst { - array set [namespace current]::data {[array get data]} - fileevent $s readable {[namespace current]::Read $s} - proc exit args {[namespace current]::SockDone $s} - [namespace current]::StartIdleTimer $s + array set [namespace current]::data {[array get data]} + fileevent $s readable {[namespace current]::Read $s} + proc exit args {[namespace current]::SockDone $s} + [namespace current]::StartIdleTimer $s }] } @@ -193,13 +193,13 @@ proc cmdsrv::Read {s} { # if {[eof $s] || [catch {read $s} line]} { - return [SockDone $s] + return [SockDone $s] } if {$line == "\n" || $line == ""} { - if {[catch {puts -nonewline $s "% "}]} { - return [SockDone $s] - } - return [StartIdleTimer $s] + if {[catch {puts -nonewline $s "% "}]} { + return [SockDone $s] + } + return [StartIdleTimer $s] } # @@ -208,10 +208,10 @@ proc cmdsrv::Read {s} { append data(cmd) $line if {[info complete $data(cmd)] == 0} { - if {[catch {puts -nonewline $s "> "}]} { - return [SockDone $s] - } - return [StartIdleTimer $s] + if {[catch {puts -nonewline $s "> "}]} { + return [SockDone $s] + } + return [StartIdleTimer $s] } # @@ -220,11 +220,11 @@ proc cmdsrv::Read {s} { catch {uplevel \#0 $data(cmd)} ret if {[catch {puts $s $ret}]} { - return [SockDone $s] + return [SockDone $s] } set data(cmd) "" if {[catch {puts -nonewline $s "% "}]} { - return [SockDone $s] + return [SockDone $s] } StartIdleTimer $s } @@ -271,8 +271,8 @@ proc cmdsrv::StopIdleTimer {s} { variable data if {[info exists data(idleevent)]} { - after cancel $data(idleevent) - unset data(idleevent) + after cancel $data(idleevent) + unset data(idleevent) } } @@ -296,7 +296,7 @@ proc cmdsrv::StartIdleTimer {s} { variable data set data(idleevent) \ - [after $data(-idletime) [list [namespace current]::SockDone $s]] + [after $data(-idletime) [list [namespace current]::SockDone $s]] } # EOF $RCSfile: cmdsrv.tcl,v $ diff --git a/tcl/phttpd/phttpd.tcl b/tcl/phttpd/phttpd.tcl index bf5d4ee..cdb446b 100644 --- a/tcl/phttpd/phttpd.tcl +++ b/tcl/phttpd/phttpd.tcl @@ -53,32 +53,32 @@ namespace eval phttpd { variable ErrorPage; # Format of error response page in html array set Httpd { - -name phttpd - -vers 1.0 - -root "." - -index index.htm + -name phttpd + -vers 1.0 + -root "." + -index index.htm } array set HttpCodes { - 400 "Bad Request" - 401 "Not Authorized" - 404 "Not Found" - 500 "Server error" + 400 "Bad Request" + 401 "Not Authorized" + 404 "Not Found" + 500 "Server error" } array set MimeTypes { - {} "text/plain" - .txt "text/plain" - .htm "text/html" - .htm "text/html" - .gif "image/gif" - .jpg "image/jpeg" - .png "image/png" + {} "text/plain" + .txt "text/plain" + .htm "text/html" + .htm "text/html" + .gif "image/gif" + .jpg "image/jpeg" + .png "image/png" } set ErrorPage { - Error: %1$s %2$s -

%3$s

-

Problem in accessing "%4$s" on this server.

-
- %5$s/%6$s Server at %7$s Port %8$s + Error: %1$s %2$s +

%3$s

+

Problem in accessing "%4$s" on this server.

+
+ %5$s/%6$s Server at %7$s Port %8$s } } @@ -104,16 +104,16 @@ proc phttpd::create {port args} { set arglen [llength $args] if {$arglen} { - if {$arglen % 2} { - error "wrong \# args, should be: key1 val1 key2 val2..." - } - set opts [array names Httpd] - foreach {arg val} $args { - if {[lsearch $opts $arg] < 0} { - error "unknown option \"$arg\"" - } - set Httpd($arg) $val - } + if {$arglen % 2} { + error "wrong \# args, should be: key1 val1 key2 val2..." + } + set opts [array names Httpd] + foreach {arg val} $args { + if {[lsearch $opts $arg] < 0} { + error "unknown option \"$arg\"" + } + set Httpd($arg) $val + } } # @@ -121,15 +121,15 @@ proc phttpd::create {port args} { # if {[info exists ::TCL_TPOOL] == 0} { - # - # Using the internal C-based thread pool - # - set initcmd "source -encoding utf-8 ../phttpd/phttpd.tcl" + # + # Using the internal C-based thread pool + # + set initcmd "source -encoding utf-8 ../phttpd/phttpd.tcl" } else { - # - # Using the Tcl-level hand-crafted thread pool - # - append initcmd "source -encoding utf-8 ../phttpd/phttpd.tcl" \n $::TCL_TPOOL + # + # Using the Tcl-level hand-crafted thread pool + # + append initcmd "source -encoding utf-8 ../phttpd/phttpd.tcl" \n $::TCL_TPOOL } set Httpd(tpid) [tpool::create -maxworkers 8 -initcmd $initcmd] @@ -258,57 +258,57 @@ proc phttpd::Read {sock} { set data(sock) $sock while {1} { - if {[catch {gets $data(sock) line} readCount] || [eof $data(sock)]} { - return [Done] - } - if {![info exists data(state)]} { - set pat {(POST|GET) ([^?]+)\??([^ ]*) HTTP/1\.[0-9]} - if {[regexp $pat $line x data(proto) data(url) data(query)]} { - set data(state) mime - continue - } else { - Log error "bad request line: (%s)" $line - Error 400 - return [Done] - } - } - - # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1 - - set state [string compare $readCount 0],$data(state),$data(proto) - switch -- $state { - "0,mime,GET" - "0,query,POST" { - Respond - return [Done] - } - "0,mime,POST" { - set data(state) query - set data(query) "" - } - "1,mime,POST" - "1,mime,GET" { - if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] { - set data(mime,[string tolower $key]) $value - } - } - "1,query,POST" { - append data(query) $line - set clen $data(mime,content-length) - if {($clen - [string length $data(query)]) <= 0} { - Respond - return [Done] - } - } - default { - if [eof $data(sock)] { - Log error "unexpected eof; client closed connection" - return [Done] - } else { - Log error "bad http protocol state: %s" $state - Error 400 - return [Done] - } - } - } + if {[catch {gets $data(sock) line} readCount] || [eof $data(sock)]} { + return [Done] + } + if {![info exists data(state)]} { + set pat {(POST|GET) ([^?]+)\??([^ ]*) HTTP/1\.[0-9]} + if {[regexp $pat $line x data(proto) data(url) data(query)]} { + set data(state) mime + continue + } else { + Log error "bad request line: (%s)" $line + Error 400 + return [Done] + } + } + + # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1 + + set state [string compare $readCount 0],$data(state),$data(proto) + switch -- $state { + "0,mime,GET" - "0,query,POST" { + Respond + return [Done] + } + "0,mime,POST" { + set data(state) query + set data(query) "" + } + "1,mime,POST" - "1,mime,GET" { + if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] { + set data(mime,[string tolower $key]) $value + } + } + "1,query,POST" { + append data(query) $line + set clen $data(mime,content-length) + if {($clen - [string length $data(query)]) <= 0} { + Respond + return [Done] + } + } + default { + if [eof $data(sock)] { + Log error "unexpected eof; client closed connection" + return [Done] + } else { + Log error "bad http protocol state: %s" $state + Error 400 + return [Done] + } + } + } } } @@ -335,7 +335,7 @@ proc phttpd::Done {} { close $data(sock) if {[info exists data]} { - unset data + unset data } set done 1 ; # Releases the request thread (See Ticket procedure) @@ -362,48 +362,48 @@ proc phttpd::Respond {} { if {[info commands $data(url)] == $data(url)} { - # - # Service URL-procedure - # - - if {[catch { - puts $data(sock) "HTTP/1.0 200 OK" - puts $data(sock) "Date: [Date]" - puts $data(sock) "Last-Modified: [Date]" - } err]} { - Log error "client closed connection prematurely: %s" $err - return - } - if {[catch {$data(url) data} err]} { - Log error "%s: %s" $data(url) $err - } + # + # Service URL-procedure + # + + if {[catch { + puts $data(sock) "HTTP/1.0 200 OK" + puts $data(sock) "Date: [Date]" + puts $data(sock) "Last-Modified: [Date]" + } err]} { + Log error "client closed connection prematurely: %s" $err + return + } + if {[catch {$data(url) data} err]} { + Log error "%s: %s" $data(url) $err + } } else { - # - # Service regular file path - # - - set mypath [Url2File $data(url)] - if {![catch {open $mypath} i]} { - if {[catch { - puts $data(sock) "HTTP/1.0 200 OK" - puts $data(sock) "Date: [Date]" - puts $data(sock) "Last-Modified: [Date [file mtime $mypath]]" - puts $data(sock) "Content-Type: [ContentType $mypath]" - puts $data(sock) "Content-Length: [file size $mypath]" - puts $data(sock) "" - fconfigure $data(sock) -translation binary -blocking 0 - fconfigure $i -translation binary - fcopy $i $data(sock) - close $i - } err]} { - Log error "client closed connection prematurely: %s" $err - } - } else { - Log error "%s: %s" $data(url) $i - Error 404 - } + # + # Service regular file path + # + + set mypath [Url2File $data(url)] + if {![catch {open $mypath} i]} { + if {[catch { + puts $data(sock) "HTTP/1.0 200 OK" + puts $data(sock) "Date: [Date]" + puts $data(sock) "Last-Modified: [Date [file mtime $mypath]]" + puts $data(sock) "Content-Type: [ContentType $mypath]" + puts $data(sock) "Content-Length: [file size $mypath]" + puts $data(sock) "" + fconfigure $data(sock) -translation binary -blocking 0 + fconfigure $i -translation binary + fcopy $i $data(sock) + close $i + } err]} { + Log error "client closed connection prematurely: %s" $err + } + } else { + Log error "%s: %s" $data(url) $i + Error 404 + } } } @@ -459,24 +459,24 @@ proc phttpd::Error {code} { append data(url) "" set msg \ - [format $ErrorPage \ - $code \ - $HttpCodes($code) \ - $HttpCodes($code) \ - $data(url) \ - $Httpd(-name) \ - $Httpd(-vers) \ - [info hostname] \ - 80 \ - ] + [format $ErrorPage \ + $code \ + $HttpCodes($code) \ + $HttpCodes($code) \ + $data(url) \ + $Httpd(-name) \ + $Httpd(-vers) \ + [info hostname] \ + 80 \ + ] if {[catch { - puts $data(sock) "HTTP/1.0 $code $HttpCodes($code)" - puts $data(sock) "Date: [Date]" - puts $data(sock) "Content-Length: [string length $msg]" - puts $data(sock) "" - puts $data(sock) $msg + puts $data(sock) "HTTP/1.0 $code $HttpCodes($code)" + puts $data(sock) "Date: [Date]" + puts $data(sock) "Content-Length: [string length $msg]" + puts $data(sock) "" + puts $data(sock) $msg } err]} { - Log error "client closed connection prematurely: %s" $err + Log error "client closed connection prematurely: %s" $err } } @@ -500,7 +500,7 @@ proc phttpd::Date {{seconds 0}} { # @c Generate a date string in HTTP format. if {$seconds == 0} { - set seconds [clock seconds] + set seconds [clock seconds] } clock format $seconds -format {%a, %d %b %Y %T %Z} -gmt 1 } @@ -553,27 +553,27 @@ proc phttpd::Url2File {url} { set level 0 foreach part [split $url /] { - set part [CgiMap $part] - if [regexp {[:/]} $part] { - return "" - } - switch -- $part { - "." { } - ".." {incr level -1} - default {incr level} - } - if {$level <= 0} { - return "" - } - lappend pathlist $part + set part [CgiMap $part] + if [regexp {[:/]} $part] { + return "" + } + switch -- $part { + "." { } + ".." {incr level -1} + default {incr level} + } + if {$level <= 0} { + return "" + } + lappend pathlist $part } set file [eval file join $pathlist] if {[file isdirectory $file]} { - return [file join $file $Httpd(-index)] + return [file join $file $Httpd(-index)] } else { - return $file + return $file } } @@ -624,7 +624,7 @@ proc phttpd::QueryMap {query} { regsub -all { } $query { {} } query; # Othewise we lose empty values foreach {key val} $query { - lappend res [CgiMap $key] [CgiMap $val] + lappend res [CgiMap $key] [CgiMap $val] } return $res } @@ -663,16 +663,16 @@ proc /monitor {array} { # puts $data(sock) [subst { - - -

[clock format [clock seconds]]

+ + +

[clock format [clock seconds]]

}] after 1 ; # Simulate blocking call puts $data(sock) [subst { - - + + }] } diff --git a/tcl/phttpd/uhttpd.tcl b/tcl/phttpd/uhttpd.tcl index 0741014..cc305ca 100644 --- a/tcl/phttpd/uhttpd.tcl +++ b/tcl/phttpd/uhttpd.tcl @@ -41,32 +41,32 @@ namespace eval uhttpd { variable ErrorPage; # Format of error response page in html array set Httpd { - -name uhttpd - -vers 1.0 - -root "" - -index index.htm + -name uhttpd + -vers 1.0 + -root "" + -index index.htm } array set HttpCodes { - 400 "Bad Request" - 401 "Not Authorized" - 404 "Not Found" - 500 "Server error" + 400 "Bad Request" + 401 "Not Authorized" + 404 "Not Found" + 500 "Server error" } array set MimeTypes { - {} "text/plain" - .txt "text/plain" - .htm "text/html" - .htm "text/html" - .gif "image/gif" - .jpg "image/jpeg" - .png "image/png" + {} "text/plain" + .txt "text/plain" + .htm "text/html" + .htm "text/html" + .gif "image/gif" + .jpg "image/jpeg" + .png "image/png" } set ErrorPage { - Error: %1$s %2$s -

%3$s

-

Problem in accessing "%4$s" on this server.

-
- %5$s/%6$s Server at %7$s Port %8$s + Error: %1$s %2$s +

%3$s

+

Problem in accessing "%4$s" on this server.

+
+ %5$s/%6$s Server at %7$s Port %8$s } } @@ -78,16 +78,16 @@ proc uhttpd::create {port args} { set arglen [llength $args] if {$arglen} { - if {$arglen % 2} { - error "wrong \# arguments, should be: key1 val1 key2 val2..." - } - set opts [array names Httpd] - foreach {arg val} $args { - if {[lsearch $opts $arg] < 0} { - error "unknown option \"$arg\"" - } - set Httpd($arg) $val - } + if {$arglen % 2} { + error "wrong \# arguments, should be: key1 val1 key2 val2..." + } + set opts [array names Httpd] + foreach {arg val} $args { + if {[lsearch $opts $arg] < 0} { + error "unknown option \"$arg\"" + } + set Httpd($arg) $val + } } set Httpd(port) $port @@ -103,9 +103,9 @@ proc uhttpd::respond {s status contype data {length 0}} { puts $s "Content-Type: $contype" if {$length} { - puts $s "Content-Length: $length" + puts $s "Content-Length: $length" } else { - puts $s "Content-Length: [string length $data]" + puts $s "Content-Length: [string length $data]" } puts $s "" @@ -133,55 +133,55 @@ proc uhttpd::Read {s} { upvar \#0 [namespace current]::Httpd$s data if {[catch {gets $s line} readCount] || [eof $s]} { - return [Done $s] + return [Done $s] } if {$readCount < 0} { - return ;# Insufficient data on non-blocking socket ! + return ;# Insufficient data on non-blocking socket ! } if {![info exists data(state)]} { - set pat {(POST|GET) ([^?]+)\??([^ ]*) HTTP/1\.[0-9]} - if {[regexp $pat $line x data(proto) data(url) data(query)]} { - return [set data(state) mime] - } else { - Log error "bad request line: %s" $line - Error $s 400 - return [Done $s] - } + set pat {(POST|GET) ([^?]+)\??([^ ]*) HTTP/1\.[0-9]} + if {[regexp $pat $line x data(proto) data(url) data(query)]} { + return [set data(state) mime] + } else { + Log error "bad request line: %s" $line + Error $s 400 + return [Done $s] + } } # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1 set state [string compare $readCount 0],$data(state),$data(proto) switch -- $state { - "0,mime,GET" - "0,query,POST" { - Respond $s - } - "0,mime,POST" { - set data(state) query - set data(query) "" - } - "1,mime,POST" - "1,mime,GET" { - if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] { - set data(mime,[string tolower $key]) $value - } - } - "1,query,POST" { - append data(query) $line - set clen $data(mime,content-length) - if {($clen - [string length $data(query)]) <= 0} { - Respond $s - } - } - default { - if [eof $s] { - Log error "unexpected eof; client closed connection" - return [Done $s] - } else { - Log error "bad http protocol state: %s" $state - Error $s 400 - return [Done $s] - } - } + "0,mime,GET" - "0,query,POST" { + Respond $s + } + "0,mime,POST" { + set data(state) query + set data(query) "" + } + "1,mime,POST" - "1,mime,GET" { + if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] { + set data(mime,[string tolower $key]) $value + } + } + "1,query,POST" { + append data(query) $line + set clen $data(mime,content-length) + if {($clen - [string length $data(query)]) <= 0} { + Respond $s + } + } + default { + if [eof $s] { + Log error "unexpected eof; client closed connection" + return [Done $s] + } else { + Log error "bad http protocol state: %s" $state + Error $s 400 + return [Done $s] + } + } } } @@ -202,49 +202,49 @@ proc uhttpd::Respond {s} { if {[uplevel \#0 info proc $data(url)] == $data(url)} { - # - # Service URL-procedure first - # - - if {[catch { - puts $s "HTTP/1.0 200 OK" - puts $s "Date: [Date]" - puts $s "Last-Modified: [Date]" - } err]} { - Log error "client closed connection prematurely: %s" $err - return [Done $s] - } - set data(sock) $s - if {[catch {$data(url) data} err]} { - Log error "%s: %s" $data(url) $err - } + # + # Service URL-procedure first + # + + if {[catch { + puts $s "HTTP/1.0 200 OK" + puts $s "Date: [Date]" + puts $s "Last-Modified: [Date]" + } err]} { + Log error "client closed connection prematurely: %s" $err + return [Done $s] + } + set data(sock) $s + if {[catch {$data(url) data} err]} { + Log error "%s: %s" $data(url) $err + } } else { - # - # Service regular file path next. - # - - set mypath [Url2File $data(url)] - if {![catch {open $mypath} i]} { - if {[catch { - puts $s "HTTP/1.0 200 OK" - puts $s "Date: [Date]" - puts $s "Last-Modified: [Date [file mtime $mypath]]" - puts $s "Content-Type: [ContentType $mypath]" - puts $s "Content-Length: [file size $mypath]" - puts $s "" - fconfigure $s -translation binary -blocking 0 - fconfigure $i -translation binary - fcopy $i $s - close $i - } err]} { - Log error "client closed connection prematurely: %s" $err - } - } else { - Log error "%s: %s" $data(url) $i - Error $s 404 - } + # + # Service regular file path next. + # + + set mypath [Url2File $data(url)] + if {![catch {open $mypath} i]} { + if {[catch { + puts $s "HTTP/1.0 200 OK" + puts $s "Date: [Date]" + puts $s "Last-Modified: [Date [file mtime $mypath]]" + puts $s "Content-Type: [ContentType $mypath]" + puts $s "Content-Length: [file size $mypath]" + puts $s "" + fconfigure $s -translation binary -blocking 0 + fconfigure $i -translation binary + fcopy $i $s + close $i + } err]} { + Log error "client closed connection prematurely: %s" $err + } + } else { + Log error "%s: %s" $data(url) $i + Error $s 404 + } } Done $s @@ -274,24 +274,24 @@ proc uhttpd::Error {s code} { append data(url) "" set msg \ - [format $ErrorPage \ - $code \ - $HttpCodes($code) \ - $HttpCodes($code) \ - $data(url) \ - $Httpd(-name) \ - $Httpd(-vers) \ - $Httpd(host) \ - $Httpd(port) \ - ] + [format $ErrorPage \ + $code \ + $HttpCodes($code) \ + $HttpCodes($code) \ + $data(url) \ + $Httpd(-name) \ + $Httpd(-vers) \ + $Httpd(host) \ + $Httpd(port) \ + ] if {[catch { - puts $s "HTTP/1.0 $code $HttpCodes($code)" - puts $s "Date: [Date]" - puts $s "Content-Length: [string length $msg]" - puts $s "" - puts $s $msg + puts $s "HTTP/1.0 $code $HttpCodes($code)" + puts $s "Date: [Date]" + puts $s "Content-Length: [string length $msg]" + puts $s "" + puts $s $msg } err]} { - Log error "client closed connection prematurely: %s" $err + Log error "client closed connection prematurely: %s" $err } } @@ -300,7 +300,7 @@ proc uhttpd::Date {{seconds 0}} { # @c Generate a date string in HTTP format. if {$seconds == 0} { - set seconds [clock seconds] + set seconds [clock seconds] } clock format $seconds -format {%a, %d %b %Y %T %Z} -gmt 1 } @@ -325,27 +325,27 @@ proc uhttpd::Url2File {url} { set level 0 foreach part [split $url /] { - set part [CgiMap $part] - if [regexp {[:/]} $part] { - return "" - } - switch -- $part { - "." { } - ".." {incr level -1} - default {incr level} - } - if {$level <= 0} { - return "" - } - lappend pathlist $part + set part [CgiMap $part] + if [regexp {[:/]} $part] { + return "" + } + switch -- $part { + "." { } + ".." {incr level -1} + default {incr level} + } + if {$level <= 0} { + return "" + } + lappend pathlist $part } set file [eval file join $pathlist] if {[file isdirectory $file]} { - return [file join $file $Httpd(-index)] + return [file join $file $Httpd(-index)] } else { - return $file + return $file } } @@ -370,7 +370,7 @@ proc uhttpd::QueryMap {query} { regsub -all { } $query { {} } query; # Othewise we lose empty values foreach {key val} $query { - lappend res [CgiMap $key] [CgiMap $val] + lappend res [CgiMap $key] [CgiMap $val] } return $res } @@ -393,16 +393,16 @@ proc /monitor {array} { # puts $data(sock) [subst { - - -

[clock format [clock seconds]]

+ + +

[clock format [clock seconds]]

}] after 1 ; # Simulate blocking call puts $data(sock) [subst { - - + + }] } diff --git a/tcl/tpool/tpool.tcl b/tcl/tpool/tpool.tcl index 80f9fa7..306bb4d 100644 --- a/tcl/tpool/tpool.tcl +++ b/tcl/tpool/tpool.tcl @@ -40,10 +40,10 @@ namespace eval tpool { set ns [namespace current] tsv::lock $ns { - if {[tsv::exists $ns count] == 0} { - tsv::set $ns count 0 - } - tsv::set $ns count -1 + if {[tsv::exists $ns count] == 0} { + tsv::set $ns count 0 + } + tsv::set $ns count -1 } variable thisScript [info script] } @@ -79,15 +79,15 @@ proc tpool::create {args} { # set usage "wrong \# args: should be \"[lindex [info level 1] 0]\ - ?-minworkers count? ?-maxworkers count?\ - ?-initcmd script? ?-exitcmd script?\ - ?-idletime seconds?\"" + ?-minworkers count? ?-maxworkers count?\ + ?-initcmd script? ?-exitcmd script?\ + ?-idletime seconds?\"" set ns [namespace current] set tpid [namespace tail $ns][tsv::incr $ns count] tsv::lock $tpid { - tsv::set $tpid name $tpid + tsv::set $tpid name $tpid } # @@ -95,16 +95,16 @@ proc tpool::create {args} { # tsv::array set $tpid { - thrworkers "" - thrwaiters "" - jobcounter 0 - refcounter 0 - numworkers 0 - -minworkers 0 - -maxworkers 4 - -idletime 0 - -initcmd "" - -exitcmd "" + thrworkers "" + thrwaiters "" + jobcounter 0 + refcounter 0 + numworkers 0 + -minworkers 0 + -maxworkers 4 + -idletime 0 + -initcmd "" + -exitcmd "" } tsv::set $tpid -initcmd "source -encoding utf-8 $thisScript" @@ -114,20 +114,20 @@ proc tpool::create {args} { # if {[llength $args] % 2} { - error $usage + error $usage } foreach {arg val} $args { - switch -- $arg { - -minworkers - - -maxworkers {tsv::set $tpid $arg $val} - -idletime {tsv::set $tpid $arg [expr {$val*1000}]} - -initcmd {tsv::append $tpid $arg \n $val} - -exitcmd {tsv::append $tpid $arg \n $val} - default { - error $usage - } - } + switch -- $arg { + -minworkers - + -maxworkers {tsv::set $tpid $arg $val} + -idletime {tsv::set $tpid $arg [expr {$val*1000}]} + -initcmd {tsv::append $tpid $arg \n $val} + -exitcmd {tsv::append $tpid $arg \n $val} + default { + error $usage + } + } } # @@ -135,7 +135,7 @@ proc tpool::create {args} { # for {set ii 0} {$ii < [tsv::set $tpid -minworkers]} {incr ii} { - Worker $tpid + Worker $tpid } return $tpid @@ -197,21 +197,21 @@ proc tpool::post {args} { set ns [namespace current] set usage "wrong \# args: should be \"[lindex [info level 1] 0]\ - ?-detached? tpoolId script\"" + ?-detached? tpoolId script\"" if {[llength $args] == 2} { - set detached 0 - set tpid [lindex $args 0] - set cmd [lindex $args 1] + set detached 0 + set tpid [lindex $args 0] + set cmd [lindex $args 1] } elseif {[llength $args] == 3} { - if {[lindex $args 0] != "-detached"} { - error $usage - } - set detached 1 - set tpid [lindex $args 1] - set cmd [lindex $args 2] + if {[lindex $args 0] != "-detached"} { + error $usage + } + set detached 1 + set tpid [lindex $args 1] + set cmd [lindex $args 2] } else { - error $usage + error $usage } # @@ -223,19 +223,19 @@ proc tpool::post {args} { set tid "" while {$tid == ""} { - tsv::lock $tpid { - set tid [tsv::lpop $tpid thrworkers] - if {$tid == "" || [catch {thread::preserve $tid}]} { - set tid "" - tsv::lpush $tpid thrwaiters [thread::id] end - if {[tsv::set $tpid numworkers]<[tsv::set $tpid -maxworkers]} { - Worker $tpid - } - } - } - if {$tid == ""} { - vwait ${ns}::waiter - } + tsv::lock $tpid { + set tid [tsv::lpop $tpid thrworkers] + if {$tid == "" || [catch {thread::preserve $tid}]} { + set tid "" + tsv::lpush $tpid thrwaiters [thread::id] end + if {[tsv::set $tpid numworkers]<[tsv::set $tpid -maxworkers]} { + Worker $tpid + } + } + } + if {$tid == ""} { + vwait ${ns}::waiter + } } # @@ -243,11 +243,11 @@ proc tpool::post {args} { # if {$detached} { - set j "" - thread::send -async $tid [list ${ns}::Run $tpid 0 $cmd] + set j "" + thread::send -async $tid [list ${ns}::Run $tpid 0 $cmd] } else { - set j [tsv::incr $tpid jobcounter] - thread::send -async $tid [list ${ns}::Run $tpid $j $cmd] ${ns}::result + set j [tsv::incr $tpid jobcounter] + thread::send -async $tid [list ${ns}::Run $tpid $j $cmd] ${ns}::result } variable jobsdone @@ -282,38 +282,38 @@ proc tpool::wait {tpid jobList {jobLeft ""}} { variable jobsdone if {$jobLeft != ""} { - upvar $jobLeft jobleft + upvar $jobLeft jobleft } set retlist "" set jobleft "" foreach j $jobList { - if {[info exists jobsdone($j)] == 0} { - continue ; # Ignore (skip) bogus job ids - } - if {$jobsdone($j) != ""} { - lappend retlist $j - } else { - lappend jobleft $j - } + if {[info exists jobsdone($j)] == 0} { + continue ; # Ignore (skip) bogus job ids + } + if {$jobsdone($j) != ""} { + lappend retlist $j + } else { + lappend jobleft $j + } } if {[llength $retlist] == 0 && [llength $jobList]} { - # - # No jobs found; wait for the first one to get ready. - # - set jobleft $jobList - while {1} { - vwait [namespace current]::result - set doneid [lindex $result 0] - set jobsdone($doneid) $result - if {[lsearch $jobList $doneid] >= 0} { - lappend retlist $doneid - set x [lsearch $jobleft $doneid] - set jobleft [lreplace $jobleft $x $x] - break - } - } + # + # No jobs found; wait for the first one to get ready. + # + set jobleft $jobList + while {1} { + vwait [namespace current]::result + set doneid [lindex $result 0] + set jobsdone($doneid) $result + if {[lsearch $jobList $doneid] >= 0} { + lappend retlist $doneid + set x [lsearch $jobleft $doneid] + set jobleft [lreplace $jobleft $x $x] + break + } + } } return $retlist @@ -341,7 +341,7 @@ proc tpool::get {tpid jobid} { variable jobsdone if {[lindex $jobsdone($jobid) 1] != 0} { - eval error [lrange $jobsdone($jobid) 2 end] + eval error [lrange $jobsdone($jobid) 2 end] } return [lindex $jobsdone($jobid) 2] @@ -387,13 +387,13 @@ proc tpool::preserve {tpid} { proc tpool::release {tpid} { tsv::lock $tpid { - if {[tsv::incr $tpid refcounter -1] <= 0} { - # Release all workers threads - foreach t [tsv::set $tpid thrworkers] { - thread::release -wait $t - } - tsv::unset $tpid ; # This is not an error; it works! - } + if {[tsv::incr $tpid refcounter -1] <= 0} { + # Release all workers threads + foreach t [tsv::set $tpid thrworkers] { + thread::release -wait $t + } + tsv::unset $tpid ; # This is not an error; it works! + } } } @@ -437,9 +437,9 @@ proc tpool::Worker {tpid} { set waiter [tsv::lpop $tpid thrwaiters] if {$waiter != ""} { - thread::send -async $waiter [subst { - set [namespace current]::waiter 1 - }] + thread::send -async $waiter [subst { + set [namespace current]::waiter 1 + }] } } @@ -462,26 +462,26 @@ proc tpool::Worker {tpid} { proc tpool::Timer {tpid} { tsv::lock $tpid { - if {[tsv::set $tpid numworkers] > [tsv::set $tpid -minworkers]} { - - # - # We have more workers than needed, so kill this one. - # We first splice ourselves from the list of active - # workers, adjust the number of workers and release - # this thread, which may exit eventually. - # - - set x [tsv::lsearch $tpid thrworkers [thread::id]] - if {$x >= 0} { - tsv::lreplace $tpid thrworkers $x $x - tsv::incr $tpid numworkers -1 - set exitcmd [tsv::set $tpid -exitcmd] - if {$exitcmd != ""} { - catch {eval $exitcmd} - } - thread::release - } - } + if {[tsv::set $tpid numworkers] > [tsv::set $tpid -minworkers]} { + + # + # We have more workers than needed, so kill this one. + # We first splice ourselves from the list of active + # workers, adjust the number of workers and release + # this thread, which may exit eventually. + # + + set x [tsv::lsearch $tpid thrworkers [thread::id]] + if {$x >= 0} { + tsv::lreplace $tpid thrworkers $x $x + tsv::incr $tpid numworkers -1 + set exitcmd [tsv::set $tpid -exitcmd] + if {$exitcmd != ""} { + catch {eval $exitcmd} + } + thread::release + } + } } } @@ -511,7 +511,7 @@ proc tpool::Run {tpid jid cmd} { variable afterevent if {$afterevent != ""} { - after cancel $afterevent + after cancel $afterevent } # @@ -520,9 +520,9 @@ proc tpool::Run {tpid jid cmd} { set code [catch {uplevel \#0 $cmd} ret] if {$code == 0} { - set res [list $jid 0 $ret] + set res [list $jid 0 $ret] } else { - set res [list $jid $code $ret $::errorInfo $::errorCode] + set res [list $jid $code $ret $::errorInfo $::errorCode] } # @@ -533,13 +533,13 @@ proc tpool::Run {tpid jid cmd} { set ns [namespace current] tsv::lock $tpid { - tsv::lpush $tpid thrworkers [thread::id] - set waiter [tsv::lpop $tpid thrwaiters] - if {$waiter != ""} { - thread::send -async $waiter [subst { - set ${ns}::waiter 1 - }] - } + tsv::lpush $tpid thrworkers [thread::id] + set waiter [tsv::lpop $tpid thrwaiters] + if {$waiter != ""} { + thread::send -async $waiter [subst { + set ${ns}::waiter 1 + }] + } } # @@ -549,7 +549,7 @@ proc tpool::Run {tpid jid cmd} { # if {[thread::release] <= 0} { - return $res + return $res } # @@ -557,9 +557,9 @@ proc tpool::Run {tpid jid cmd} { # if {[set idle [tsv::set $tpid -idletime]]} { - set afterevent [after $idle [subst { - ${ns}::Timer $tpid - }]] + set afterevent [after $idle [subst { + ${ns}::Timer $tpid + }]] } return $res diff --git a/tests/all.tcl b/tests/all.tcl index a3a3af6..156dbec 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -47,7 +47,7 @@ foreach file [lsort [::tcltest::getMatchingFiles]] { set tail [file tail $file] puts stdout $tail if {[catch {source -encoding utf-8 $file} msg]} { - puts stdout $msg + puts stdout $msg } } diff --git a/tests/store-load.tcl b/tests/store-load.tcl index 741f73c..5b6e415 100644 --- a/tests/store-load.tcl +++ b/tests/store-load.tcl @@ -7,12 +7,12 @@ if {[llength $argv] != 3} { puts "Usage: $argv0 handle path times" puts { handle - A persistent storage handle (see [tsv::array bind] manpage). + A persistent storage handle (see [tsv::array bind] manpage). path - The path to file containing lines in the form of "keyval", where - key is a single-word and val is everyting else. + The path to file containing lines in the form of "keyval", where + key is a single-word and val is everyting else. times - The number of times to reload the data from persistent storage. + The number of times to reload the data from persistent storage. This script reads lines of data from and stores them into the persistent storage described by . Values for duplicate keys are @@ -35,18 +35,18 @@ set start [clock milliseconds] set pairs 0 while {[gets $fd line] > 0} { if {[string index $line 0] eq {#}} { - continue + continue } set tab [string first { } $line] if {$tab < 0} { - continue + continue } set k [string range $line 0 $tab-1] set v [string range $line $tab+1 end] if {![tsv::exists a $k]} { - incr pairs + incr pairs } tsv::lappend a $k $v diff --git a/tests/thread.test b/tests/thread.test index e5051f2..b4b98f6 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -24,11 +24,11 @@ set tcltest::mainThread [thread::id] proc ThreadReap {} { while {[llength [thread::names]] > 1} { - foreach tid [thread::names] { - if {$tid != $::tcltest::mainThread} { - catch {thread::release -wait $tid} - } - } + foreach tid [thread::names] { + if {$tid != $::tcltest::mainThread} { + catch {thread::release -wait $tid} + } + } } llength [thread::names] } @@ -58,13 +58,13 @@ test thread-4.1 {thread::create: create one shot thread} { ThreadReap thread::create {set x 5} foreach try {0 1 2 4 5 6} { - # Try various ways to yield - update - after 10 - set l [llength [thread::names]] - if {$l == 1} { - break - } + # Try various ways to yield + update + after 10 + set l [llength [thread::names]] + if {$l == 1} { + break + } } ThreadReap set l @@ -342,13 +342,13 @@ test thread-13.0 {thread::broadcast} { ThreadReap catch {unset tids} foreach i {1 2 3 4} { - lappend tids [thread::create] + lappend tids [thread::create] } thread::broadcast {set x 5} update catch {unset r} foreach tid $tids { - lappend r [thread::send $tid {if {[info exists x]} {set x}}] + lappend r [thread::send $tid {if {[info exists x]} {set x}}] } ThreadReap set r @@ -486,9 +486,9 @@ test thread-16.2 {thread::errorproc - async reporting} { set etid "" set emsg "" proc myerrproc {tid msg} { - global etid emsg - set etid $tid - set emsg $msg + global etid emsg + set etid $tid + set emsg $msg } ThreadReap thread::errorproc myerrproc @@ -530,13 +530,13 @@ test thread-17.2 {thread::transfer - target thread dying} {chanTransfer} { test thread-17.3 {thread::transfer - clearing of fileevents} {chanTransfer} { proc _HandleIt_ {} { - global gotEvents tid file - if {$gotEvents == 0} { - thread::transfer $tid $file - # From now on no events should be delivered anymore, - # restricting the end value to 1 - } - incr gotEvents + global gotEvents tid file + if {$gotEvents == 0} { + thread::transfer $tid $file + # From now on no events should be delivered anymore, + # restricting the end value to 1 + } + incr gotEvents } ThreadReap set tid [thread::create] @@ -900,9 +900,9 @@ test thread-19.12 {thread::mutex - lock exclusive between threads} { set tid [thread::create] set emutex [thread::mutex create] thread::send -async $tid [subst { - thread::mutex lock $emutex - after 2000 - thread::mutex unlock $emutex + thread::mutex lock $emutex + after 2000 + thread::mutex unlock $emutex }] update after 10 @@ -985,9 +985,9 @@ test thread-20.8 {thread::rwmutex - readlock mutex} { set tid [thread::create] set rwmutex [thread::rwmutex create] thread::send -async $tid [subst { - thread::rwmutex rlock $rwmutex - after 1000 - thread::rwmutex unlock $rwmutex + thread::rwmutex rlock $rwmutex + after 1000 + thread::rwmutex unlock $rwmutex }] update after 10 @@ -1005,9 +1005,9 @@ test thread-20.9 {thread::rwmutex - writelock mutex} { set tid [thread::create] set rwmutex [thread::rwmutex create] thread::send -async $tid [subst { - thread::rwmutex wlock $rwmutex - after 2000 - thread::rwmutex unlock $rwmutex + thread::rwmutex wlock $rwmutex + after 2000 + thread::rwmutex unlock $rwmutex }] update after 10 @@ -1142,7 +1142,7 @@ test thread-21.12 {thread::cond - wait locked mutex from wrong thread} { set cond [thread::cond create] thread::mutex lock $emutex thread::send -async $tid [subst -nocommands { - set code [catch {thread::cond wait $cond $emutex 1000} result] + set code [catch {thread::cond wait $cond $emutex 1000} result] }] update after 20 @@ -1180,10 +1180,10 @@ test thread-21.15 {thread::cond - regular timed wait} { set emutex [thread::mutex create] set cond [thread::cond create] thread::send -async $tid [subst { - thread::mutex lock $emutex - thread::cond wait $cond $emutex 2000 - thread::mutex unlock $emutex - set test 1 + thread::mutex lock $emutex + thread::cond wait $cond $emutex 2000 + thread::mutex unlock $emutex + set test 1 }] update after 10 @@ -1203,9 +1203,9 @@ test thread-21.16 {thread::cond - delete waited variable} { set emutex [thread::mutex create] set cond [thread::cond create] thread::send -async $tid [subst { - thread::mutex lock $emutex - thread::cond wait $cond $emutex 500 - thread::mutex unlock $emutex + thread::mutex lock $emutex + thread::cond wait $cond $emutex 500 + thread::mutex unlock $emutex }] update after 10 @@ -1221,11 +1221,11 @@ test thread-21.16 {thread::cond - delete waited variable} { test thread-22.1 {thread::send -command} { ThreadReap after 0 [list ::apply [list {} { - set tid [thread::create] - thread::send -command $tid {lindex hello} [list ::apply [list args { - variable result - set result $args - } [namespace current]]] + set tid [thread::create] + thread::send -command $tid {lindex hello} [list ::apply [list args { + variable result + set result $args + } [namespace current]]] } [namespace current]]] vwait [namespace current]::result ThreadReap diff --git a/tests/tkt-84be1b5a73.test b/tests/tkt-84be1b5a73.test index bd4ba77..7b1f717 100644 --- a/tests/tkt-84be1b5a73.test +++ b/tests/tkt-84be1b5a73.test @@ -9,17 +9,17 @@ test tkt-84be1b5a73 {Ticket 84be1b5a73} -body { set resultvar() {} trace add variable resultvar() write { - unset -nocomplain resultvar() - list} + unset -nocomplain resultvar() + list} proc errorproc {tid einfo} {} thread::errorproc errorproc thread::send -async $t { - error "" + error "" } resultvar() after 1000 { - set forever 1 + set forever 1 } vwait forever } -returnCodes 0 diff --git a/tests/tsv.test b/tests/tsv.test index feaa0ba..d10decf 100644 --- a/tests/tsv.test +++ b/tests/tsv.test @@ -15,28 +15,28 @@ foreach backend $backends { set ::handle $backend:$db proc setup {} { - tsv::array bind a $::handle + tsv::array bind a $::handle } proc cleanup {} { - tsv::array unbind a + tsv::array unbind a } test tsv-$backend-1.0 {tsv::array isboud} \ -constraints have_$backend \ -setup { - setup + setup } -body { - tsv::array isbound a + tsv::array isbound a } -cleanup { - cleanup + cleanup } -result {1} test tsv-$backend-1.1 {tsv::array bind - empty} \ -constraints have_$backend \ -setup { - setup + setup } -body { - tsv::array names b + tsv::array names b } -cleanup { cleanup } -result {} @@ -44,61 +44,61 @@ foreach backend $backends { test tsv-$backend-1.2 {tsv::set} \ -constraints have_$backend \ -setup { - setup + setup } -body { - tsv::set a Key Val + tsv::set a Key Val } -cleanup { - cleanup + cleanup } -result {Val} test tsv-$backend-1.3 {tsv::get - previously set was persisted} \ -constraints have_$backend \ -setup { - setup + setup } -body { - tsv::get a Key + tsv::get a Key } -cleanup { - cleanup + cleanup } -result {Val} test tsv-$backend-1.4 {tsv::array names - previously set was persisted} \ -constraints have_$backend \ -setup { - setup + setup } -body { - tsv::array names a + tsv::array names a } -cleanup { - cleanup + cleanup } -result {Key} test tsv-$backend-1.5 {tsv::exists - previously set exists} \ -constraints have_$backend \ -setup { - setup + setup } -body { - tsv::exists a Key + tsv::exists a Key } -cleanup { - cleanup + cleanup } -result {1} test tsv-$backend-1.6 {tsv::pop - get previously set} \ -constraints have_$backend \ -setup { - setup + setup } -body { - tsv::pop a Key + tsv::pop a Key } -cleanup { - cleanup + cleanup } -result {Val} test tsv-$backend-1.7 {tsv::exists - popped was removed} \ -constraints have_$backend \ -setup { - setup + setup } -body { - tsv::exists a Key + tsv::exists a Key } -cleanup { - cleanup + cleanup } -result {0} file delete -force $db diff --git a/win/nmakehlp.c b/win/nmakehlp.c index b0799f8..8482577 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -90,7 +90,7 @@ main( case 'c': if (argc != 3) { chars = snprintf(msg, sizeof(msg) - 1, - "usage: %s -c \n" + "usage: %s -c \n" "Tests for whether cl.exe supports an option\n" "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, @@ -101,7 +101,7 @@ main( case 'l': if (argc < 3) { chars = snprintf(msg, sizeof(msg) - 1, - "usage: %s -l ? ...?\n" + "usage: %s -l ? ...?\n" "Tests for whether link.exe supports an option\n" "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, @@ -318,11 +318,11 @@ CheckForCompilerFeature( */ return !(strstr(Out.buffer, "D4002") != NULL - || strstr(Err.buffer, "D4002") != NULL - || strstr(Out.buffer, "D9002") != NULL - || strstr(Err.buffer, "D9002") != NULL - || strstr(Out.buffer, "D2021") != NULL - || strstr(Err.buffer, "D2021") != NULL); + || strstr(Err.buffer, "D4002") != NULL + || strstr(Out.buffer, "D9002") != NULL + || strstr(Err.buffer, "D9002") != NULL + || strstr(Out.buffer, "D2021") != NULL + || strstr(Err.buffer, "D2021") != NULL); } static int @@ -493,9 +493,9 @@ IsIn( /* * GetVersionFromFile -- - * Looks for a match string in a file and then returns the version - * following the match where a version is anything acceptable to - * package provide or package ifneeded. + * Looks for a match string in a file and then returns the version + * following the match where a version is anything acceptable to + * package provide or package ifneeded. */ static const char * @@ -600,9 +600,9 @@ list_free(list_item_t **listPtrPtr) * * Usage is something like: * nmakehlp -S << $** > $@ - * @PACKAGE_NAME@ $(PACKAGE_NAME) - * @PACKAGE_VERSION@ $(PACKAGE_VERSION) - * << + * @PACKAGE_NAME@ $(PACKAGE_NAME) + * @PACKAGE_VERSION@ $(PACKAGE_VERSION) + * << */ static int @@ -747,8 +747,9 @@ static int LocateDependencyHelper(const char *dir, const char *keypath) #else hSearch = FindFirstFile(path, &finfo); #endif - if (hSearch == INVALID_HANDLE_VALUE) + if (hSearch == INVALID_HANDLE_VALUE) { return 1; /* Not found */ + } /* Loop through all subdirs checking if the keypath is under there */ ret = 1; /* Assume not found */ @@ -758,11 +759,13 @@ static int LocateDependencyHelper(const char *dir, const char *keypath) * We need to check it is a directory despite the * FindExSearchLimitToDirectories in the above call. See SDK docs */ - if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0) + if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0) { continue; + } sublen = strlen(finfo.cFileName); - if ((dirlen+1+sublen+1+keylen+1) > sizeof(path)) + if ((dirlen+1+sublen+1+keylen+1) > sizeof(path)) { continue; /* Path does not fit, assume not matched */ + } strncpy(path+dirlen+1, finfo.cFileName, sublen); path[dirlen+1+sublen] = '\\'; strncpy(path+dirlen+1+sublen+1, keypath, keylen+1); @@ -782,13 +785,13 @@ static int LocateDependencyHelper(const char *dir, const char *keypath) * LocateDependency -- * * Locates a dependency for a package. - * keypath - a relative path within the package directory - * that is used to confirm it is the correct directory. + * keypath - a relative path within the package directory + * that is used to confirm it is the correct directory. * The search path for the package directory is currently only - * the parent and grandparent of the current working directory. - * If found, the command prints - * name_DIRPATH= - * and returns 0. If not found, does not print anything and returns 1. + * the parent and grandparent of the current working directory. + * If found, the command prints + * name_DIRPATH= + * and returns 0. If not found, does not print anything and returns 1. */ static int LocateDependency(const char *keypath) { diff --git a/win/rules.vc b/win/rules.vc index 143ea9e..d459559 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -24,7 +24,7 @@ _RULES_VC = 1 # For modifications that are not backward-compatible, you *must* change # the major version. RULES_VERSION_MAJOR = 1 -RULES_VERSION_MINOR = 11 +RULES_VERSION_MINOR = 12 # The PROJECT macro must be defined by parent makefile. !if "$(PROJECT)" == "" @@ -1135,8 +1135,8 @@ STUBPREFIX = $(PROJECT)stub # # TIP 430. Unused for 8.6 but no harm defining it to allow a common rules.vc -TCLSCRIPTZIPNAME = libtcl$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)$(TCL_PATCH_LETTER)$(TCL_RELEASE_SERIAL).zip -TKSCRIPTZIPNAME = libtk$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION)$(TK_PATCH_LETTER)$(TK_RELEASE_SERIAL).zip +TCL_ZIP_FILE = libtcl$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)$(TCL_PATCH_LETTER)$(TCL_RELEASE_SERIAL).zip +TK_ZIP_FILE = libtk$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION)$(TK_PATCH_LETTER)$(TK_RELEASE_SERIAL).zip !if $(DOING_TCL) TCLSHNAME = $(PROJECT)sh$(VERSION)$(SUFX).exe @@ -1144,7 +1144,7 @@ TCLSH = $(OUT_DIR)\$(TCLSHNAME) TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) -TCLSCRIPTZIP = $(OUT_DIR)\$(TCLSCRIPTZIPNAME) +TCLSCRIPTZIP = $(OUT_DIR)\$(TCL_ZIP_FILE) !if $(TCL_MAJOR_VERSION) == 8 TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib @@ -1180,7 +1180,7 @@ TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)t$(SUFX:t=).lib TCL_LIBRARY = $(_TCLDIR)\lib TCLREGLIB = $(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib TCLDDELIB = $(_TCLDIR)\lib\tcldde14$(SUFX:t=).lib -TCLSCRIPTZIP = $(_TCLDIR)\lib\$(TCLSCRIPTZIPNAME) +TCLSCRIPTZIP = $(_TCLDIR)\lib\$(TCL_ZIP_FILE) TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target TCL_INCLUDES = -I"$(_TCLDIR)\include" @@ -1204,7 +1204,7 @@ TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)t$(SUFX:t=).lib TCL_LIBRARY = $(_TCLDIR)\library TCLREGLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib TCLDDELIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde14$(SUFX:t=).lib -TCLSCRIPTZIP = $(_TCLDIR)\win\$(BUILDDIRTOP)\$(TCLSCRIPTZIPNAME) +TCLSCRIPTZIP = $(_TCLDIR)\win\$(BUILDDIRTOP)\$(TCL_ZIP_FILE) TCLTOOLSDIR = $(_TCLDIR)\tools TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win" @@ -1248,12 +1248,12 @@ TKSTUBLIBNAME = tkstub.lib !endif !if $(DOING_TK) -WISH = $(OUT_DIR)\$(WISHNAME) +WISH = $(OUT_DIR)\$(WISHNAME) TKSTUBLIB = $(OUT_DIR)\$(TKSTUBLIBNAME) TKIMPLIB = $(OUT_DIR)\$(TKIMPLIBNAME) TKLIB = $(OUT_DIR)\$(TKLIBNAME) TK_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" -TKSCRIPTZIP = $(OUT_DIR)\$(TKSCRIPTZIPNAME) +TKSCRIPTZIP = $(OUT_DIR)\$(TK_ZIP_FILE) !else # effectively NEED_TK @@ -1268,7 +1268,7 @@ TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX:t=).lib TKIMPLIB = $(_TKDIR)\lib\$(TKIMPLIBNAME) !endif TK_INCLUDES = -I"$(_TKDIR)\include" -TKSCRIPTZIP = $(_TKDIR)\lib\$(TKSCRIPTZIPNAME) +TKSCRIPTZIP = $(_TKDIR)\lib\$(TK_ZIP_FILE) !else # Building against Tk sources @@ -1282,7 +1282,7 @@ TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX:t=).lib TKIMPLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKIMPLIBNAME) !endif TK_INCLUDES = -I"$(_TKDIR)\generic" -I"$(_TKDIR)\win" -I"$(_TKDIR)\xlib" -TKSCRIPTZIP = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKSCRIPTZIPNAME) +TKSCRIPTZIP = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TK_ZIP_FILE) !endif # TKINSTALL @@ -1294,7 +1294,8 @@ tklibs = "$(TKSTUBLIB)" "$(TKIMPLIB)" # Various output paths PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib PRJLIBNAME8 = $(PROJECT)$(VERSION)$(SUFX).$(EXT) -PRJLIBNAME9 = tcl9$(PROJECT)$(VERSION)$(SUFX).$(EXT) +# Even when building against Tcl 8, PRJLIBNAME9 must not have "t" +PRJLIBNAME9 = tcl9$(PROJECT)$(VERSION)$(SUFX:t=).$(EXT) !if $(TCL_MAJOR_VERSION) == 8 || "$(TCL_BUILD_FOR)" == "8" PRJLIBNAME = $(PRJLIBNAME8) !else @@ -1446,9 +1447,6 @@ OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1 !if "$(_USE_64BIT_TIME_T)" == "1" OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T=1 !endif - -# _ATL_XP_TARGETING - Newer SDK's need this to build for XP -COMPILERFLAGS = /D_ATL_XP_TARGETING !endif !if "$(TCL_BUILD_FOR)" == "8" OPTDEFINES = $(OPTDEFINES) /DTCL_MAJOR_VERSION=8 @@ -1459,9 +1457,9 @@ OPTDEFINES = $(OPTDEFINES) /DTCL_MAJOR_VERSION=8 # so we pass both !if !$(DOING_TCL) && !$(DOING_TK) PKGNAMEFLAGS = /DPACKAGE_NAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ - /DPACKAGE_TCLNAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ - /DPACKAGE_VERSION="\"$(DOTVERSION)\"" \ - /DMODULE_SCOPE=extern + /DPACKAGE_TCLNAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ + /DPACKAGE_VERSION="\"$(DOTVERSION)\"" \ + /DMODULE_SCOPE=extern !endif # crt picks the C run time based on selected OPTS @@ -1798,18 +1796,18 @@ VS_VERSION_INFO VERSIONINFO BEGIN BLOCK "StringFileInfo" BEGIN - BLOCK "040904b0" - BEGIN - VALUE "FileDescription", "Tcl extension " PROJECT - VALUE "OriginalFilename", PRJLIBNAME - VALUE "FileVersion", DOTVERSION - VALUE "ProductName", "Package " PROJECT " for Tcl" - VALUE "ProductVersion", DOTVERSION - END + BLOCK "040904b0" + BEGIN + VALUE "FileDescription", "Tcl extension " PROJECT + VALUE "OriginalFilename", PRJLIBNAME + VALUE "FileVersion", DOTVERSION + VALUE "ProductName", "Package " PROJECT " for Tcl" + VALUE "ProductVersion", DOTVERSION + END END BLOCK "VarFileInfo" BEGIN - VALUE "Translation", 0x409, 1200 + VALUE "Translation", 0x409, 1200 END END