From ac91fd3fc0f4e56af87be3a914a904402eb2714b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 21 Aug 2024 13:41:13 +0000 Subject: [PATCH] 3.0b4 -> 3.0b5. More indenting --- ChangeLog | 116 ++-- Makefile.in | 4 +- aclocal.m4 | 158 +++--- configure | 420 +++++++------- configure.ac | 20 +- doc/format.tcl | 28 +- generic/threadCmd.c | 2 +- lib/ttrace.tcl | 1204 ++++++++++++++++++++--------------------- naviserver.m4 | 32 +- project.shed | 2 +- tcl/README | 28 +- tcl/cmdsrv/cmdsrv.tcl | 56 +- tcl/phttpd/phttpd.tcl | 334 ++++++------ tcl/phttpd/uhttpd.tcl | 298 +++++----- tcl/tpool/tpool.tcl | 254 ++++----- tests/all.tcl | 4 +- tests/store-load.tcl | 14 +- win/pkg.vc | 2 +- 18 files changed, 1488 insertions(+), 1488 deletions(-) diff --git a/ChangeLog b/ChangeLog index 5f577921..4f37b853 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 @@ -612,7 +612,7 @@ * 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. @@ -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,7 +1150,7 @@ * generic/threadPoolCmd.c: fixed one missing mutex unlock in the ThreadRelease. - * tcl/tpool/tpool.tcl: implemented missing API calls found + * tcl/tpool/tpool.tcl: implemented missing API calls found in the C-level implementation. * tcl/phttpd/phttpd.tcl: simplified switching to Tcl-level @@ -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 @@ -1319,7 +1319,7 @@ 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 @@ -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 @@ -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 c6f377f7..d878a38d 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?)'; \ @@ -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/aclocal.m4 b/aclocal.m4 index 995e3a29..5375a29c 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 9c9b1b5e..c728c54a 100755 --- a/configure +++ b/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.72 for thread 3.0b4. +# Generated by GNU Autoconf 2.72 for thread 3.0b5. # # # Copyright (C) 1992-1996, 1998-2017, 2020-2023 Free Software Foundation, @@ -601,8 +601,8 @@ MAKEFLAGS= # Identity of this package. PACKAGE_NAME='thread' PACKAGE_TARNAME='thread' -PACKAGE_VERSION='3.0b4' -PACKAGE_STRING='thread 3.0b4' +PACKAGE_VERSION='3.0b5' +PACKAGE_STRING='thread 3.0b5' PACKAGE_BUGREPORT='' PACKAGE_URL='' @@ -1335,7 +1335,7 @@ if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -'configure' configures thread 3.0b4 to adapt to many kinds of systems. +'configure' configures thread 3.0b5 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1397,7 +1397,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of thread 3.0b4:";; + short | recursive ) echo "Configuration of thread 3.0b5:";; esac cat <<\_ACEOF @@ -1503,7 +1503,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -thread configure 3.0b4 +thread configure 3.0b5 generated by GNU Autoconf 2.72 Copyright (C) 2023 Free Software Foundation, Inc. @@ -1810,7 +1810,7 @@ cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by thread $as_me 3.0b4, which was +It was created by thread $as_me 3.0b5, which was generated by GNU Autoconf 2.72. Invocation command line was $ $0$ac_configure_args_raw @@ -3875,11 +3875,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 @@ -3890,9 +3890,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 @@ -5482,51 +5482,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 @@ -5546,60 +5546,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 @@ -5626,31 +5626,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 @@ -6351,7 +6351,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; } @@ -6359,11 +6359,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 @@ -6802,14 +6802,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 @@ -6821,12 +6821,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} " @@ -7543,19 +7543,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 @@ -7583,7 +7583,7 @@ then : LDFLAGS="$LDFLAGS $PTHREAD_LIBS" fi ;; - esac + esac if test $doRpath = yes then : @@ -8047,11 +8047,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 @@ -8340,7 +8340,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 @@ -8783,15 +8783,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; } @@ -8949,7 +8949,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; } @@ -9053,8 +9053,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 @@ -9417,37 +9417,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; } @@ -9487,25 +9487,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 @@ -9517,37 +9517,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 @@ -10139,7 +10139,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by thread $as_me 3.0b4, which was +This file was extended by thread $as_me 3.0b5, which was generated by GNU Autoconf 2.72. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -10194,7 +10194,7 @@ ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ -thread config.status 3.0b4 +thread config.status 3.0b5 configured by $0, generated by GNU Autoconf 2.72, with options \\"\$ac_cs_config\\" diff --git a/configure.ac b/configure.ac index 8732b9ab..9e75b379 100644 --- a/configure.ac +++ b/configure.ac @@ -17,7 +17,7 @@ dnl to configure the system for the local environment. # so you can encode the package version directly into the source files. #----------------------------------------------------------------------- -AC_INIT([thread],[3.0b4]) +AC_INIT([thread],[3.0b5]) #-------------------------------------------------------------------- # Call TEA_INIT as the first TEA_ macro to set up initial vars. @@ -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 394c4625..ffff9a66 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/threadCmd.c b/generic/threadCmd.c index f6000f9d..291f0a77 100644 --- a/generic/threadCmd.c +++ b/generic/threadCmd.c @@ -29,7 +29,7 @@ * files built as part of that shell. Example: basekits. */ #ifndef PACKAGE_VERSION -#define PACKAGE_VERSION "3.0b4" +#define PACKAGE_VERSION "3.0b5" #endif /* diff --git a/lib/ttrace.tcl b/lib/ttrace.tcl index 69bbcb62..966775f1 100644 --- a/lib/ttrace.tcl +++ b/lib/ttrace.tcl @@ -46,35 +46,35 @@ 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 - package provide ttrace 3.0b4 - package provide Ttrace 3.0b4 + package provide ttrace 3.0b5 + package provide Ttrace 3.0b5 # Package variables variable resolvers "" ; # List of registered resolvers @@ -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 f0ab1fca..430a83f7 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/project.shed b/project.shed index 9222df7b..30829e36 100644 --- a/project.shed +++ b/project.shed @@ -64,7 +64,7 @@ e47b6a79a963c99b7de15a4817b3010fbb3dd693 { entity { name: thread shed_class: package - version: 3.0b4 + version: 3.0b5 } meta { build: tea diff --git a/tcl/README b/tcl/README index 3556ebe7..4af53987 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.7 (or later) Tcl shell. diff --git a/tcl/cmdsrv/cmdsrv.tcl b/tcl/cmdsrv/cmdsrv.tcl index 3f2deabf..1eb31e30 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 cmdsrv.tcl} + -idletime 300000 + -initcmd {source 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 9682b112..84871ab4 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 ../phttpd/phttpd.tcl" + # + # Using the internal C-based thread pool + # + set initcmd "source ../phttpd/phttpd.tcl" } else { - # - # Using the Tcl-level hand-crafted thread pool - # - append initcmd "source ../phttpd/phttpd.tcl" \n $::TCL_TPOOL + # + # Using the Tcl-level hand-crafted thread pool + # + append initcmd "source ../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 7757762e..6a8bb5c1 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 9ef3b26b..066e089c 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 $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 74eb3f32..58b11130 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -9,7 +9,7 @@ package require tcltest ::tcltest::loadTestedCommands -package require -exact thread 3.0b4 +package require -exact thread 3.0b5 set ::tcltest::testSingleFile false set ::tcltest::testsDirectory [file dir [info script]] @@ -47,7 +47,7 @@ foreach file [lsort [::tcltest::getMatchingFiles]] { set tail [file tail $file] puts stdout $tail if {[catch {source $file} msg]} { - puts stdout $msg + puts stdout $msg } } diff --git a/tests/store-load.tcl b/tests/store-load.tcl index 741f73c6..5b6e415e 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/win/pkg.vc b/win/pkg.vc index a92958ae..e70b1752 100644 --- a/win/pkg.vc +++ b/win/pkg.vc @@ -3,4 +3,4 @@ PACKAGE_MAJOR = 3 PACKAGE_MINOR = 0 -PACKAGE_VERSION = "3.0b4" +PACKAGE_VERSION = "3.0b5"