ag/cpython-source-deps
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Import Tcl 8.6.12

Browse Source
This commit is contained in:
Steve Dower
2021-11-08 17:30:58 +00:00
parent 1aadb2455c
commit 674867e7e6
608 changed files with 78089 additions and 60360 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1914
pkgs/thread2.8.7/ChangeLog Normal file
View File

File diff suppressed because it is too large Load Diff

482
pkgs/thread2.8.7/Makefile.in Normal file
View File

@@ -0,0 +1,482 @@
# Makefile.in --
#
# This file is a Makefile for the Thread Extension. If it has the name
# "Makefile.in" then it is a template for a Makefile; to generate the
# actual Makefile, run "./configure", which is a configuration script
# generated by the "autoconf" program (constructs like "@foo@" will get
# replaced in the actual Makefile.
#
# Copyright (c) 1999 Scriptics Corporation.
# Copyright (c) 2002-2005 ActiveState Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#========================================================================
# Add additional lines to handle any additional AC_SUBST cases that
# have been added in a customized configure script.
#========================================================================
#SAMPLE_NEW_VAR = @SAMPLE_NEW_VAR@
#========================================================================
# Nothing of the variables below this line should need to be changed.
# Please check the TARGETS section below to make sure the make targets
# are correct.
#========================================================================
#========================================================================
# The names of the source files is defined in the configure script.
# The object files are used for linking into the final library.
# This will be used when a dist target is added to the Makefile.
# It is not important to specify the directory, as long as it is the
# $(srcdir) or in the generic, win or unix subdirectory.
#========================================================================
PKG_SOURCES = @PKG_SOURCES@
PKG_OBJECTS = @PKG_OBJECTS@
PKG_STUB_SOURCES = @PKG_STUB_SOURCES@
PKG_STUB_OBJECTS = @PKG_STUB_OBJECTS@
#========================================================================
# PKG_TCL_SOURCES identifies Tcl runtime files that are associated with
# this package that need to be installed, if any.
#========================================================================
PKG_TCL_SOURCES = @PKG_TCL_SOURCES@
#========================================================================
# This is a list of public header files to be installed, if any.
#========================================================================
PKG_HEADERS = @PKG_HEADERS@
#========================================================================
# "PKG_LIB_FILE" refers to the library (dynamic or static as per
# configuration options) composed of the named objects.
#========================================================================
PKG_LIB_FILE = @PKG_LIB_FILE@
PKG_LIB_FILE8 = @PKG_LIB_FILE8@
PKG_LIB_FILE9 = @PKG_LIB_FILE9@
PKG_STUB_LIB_FILE = @PKG_STUB_LIB_FILE@
lib_BINARIES = $(PKG_LIB_FILE)
BINARIES = $(lib_BINARIES)
SHELL = @SHELL@
srcdir = @srcdir@
prefix = @prefix@
exec_prefix = @exec_prefix@
bindir = @bindir@
libdir = @libdir@
includedir = @includedir@
datarootdir = @datarootdir@
runstatedir = @runstatedir@
datadir = @datadir@
mandir = @mandir@
DESTDIR =
PKG_DIR = $(PACKAGE_NAME)$(PACKAGE_VERSION)
pkgdatadir = $(datadir)/$(PKG_DIR)
pkglibdir = $(libdir)/$(PKG_DIR)
pkgincludedir = $(includedir)/$(PKG_DIR)
top_builddir = .
INSTALL_OPTIONS =
INSTALL = @INSTALL@ $(INSTALL_OPTIONS)
INSTALL_DATA_DIR = @INSTALL_DATA_DIR@
INSTALL_DATA = @INSTALL_DATA@
INSTALL_PROGRAM = @INSTALL_PROGRAM@
INSTALL_SCRIPT = @INSTALL_SCRIPT@
INSTALL_LIBRARY = @INSTALL_LIBRARY@
PACKAGE_NAME = @PACKAGE_NAME@
PACKAGE_VERSION = @PACKAGE_VERSION@
CC = @CC@
CCLD = @CCLD@
CFLAGS_DEFAULT = @CFLAGS_DEFAULT@
CFLAGS_WARNING = @CFLAGS_WARNING@
EXEEXT = @EXEEXT@
LDFLAGS_DEFAULT = @LDFLAGS_DEFAULT@
MAKE_LIB = @MAKE_LIB@
MAKE_STUB_LIB = @MAKE_STUB_LIB@
OBJEXT = @OBJEXT@
RANLIB = @RANLIB@
RANLIB_STUB = @RANLIB_STUB@
SHLIB_CFLAGS = @SHLIB_CFLAGS@
SHLIB_LD = @SHLIB_LD@
SHLIB_LD_LIBS = @SHLIB_LD_LIBS@
STLIB_LD = @STLIB_LD@
#TCL_DEFS = @TCL_DEFS@
TCL_BIN_DIR = @TCL_BIN_DIR@
TCL_SRC_DIR = @TCL_SRC_DIR@
#TK_BIN_DIR = @TK_BIN_DIR@
#TK_SRC_DIR = @TK_SRC_DIR@
# Not used, but retained for reference of what libs Tcl required
#TCL_LIBS = @TCL_LIBS@
#========================================================================
# TCLLIBPATH seeds the auto_path in Tcl's init.tcl so we can test our
# package without installing. The other environment variables allow us
# to test against an uninstalled Tcl. Add special env vars that you
# require for testing here (like TCLX_LIBRARY).
#========================================================================
EXTRA_PATH = $(top_builddir):$(TCL_BIN_DIR)
#EXTRA_PATH = $(top_builddir):$(TCL_BIN_DIR):$(TK_BIN_DIR)
TCLLIBPATH = $(top_builddir)
TCLSH_ENV = TCL_LIBRARY=`@CYGPATH@ $(TCL_SRC_DIR)/library`
PKG_ENV = TCL_THREAD_LIBRARY=`@CYGPATH@ $(srcdir)/lib` \
@LD_LIBRARY_PATH_VAR@="$(EXTRA_PATH):$(@LD_LIBRARY_PATH_VAR@)" \
PATH="$(EXTRA_PATH):$(PATH)" \
TCLLIBPATH="$(TCLLIBPATH) $(top_builddir)/../lib"
TCLSH_PROG = @TCLSH_PROG@
TCLSH = $(TCLSH_ENV) $(PKG_ENV) $(TCLSH_PROG)
#WISH_ENV = TK_LIBRARY=`@CYGPATH@ $(TK_SRC_DIR)/library`
#WISH_PROG = @WISH_PROG@
#WISH = $(TCLSH_ENV) $(WISH_ENV) $(PKG_ENV) $(WISH_PROG)
SHARED_BUILD = @SHARED_BUILD@
INCLUDES = @PKG_INCLUDES@ @TCL_INCLUDES@
#INCLUDES = @PKG_INCLUDES@ @TCL_INCLUDES@ @TK_INCLUDES@ @TK_XINCLUDES@
PKG_CFLAGS = @PKG_CFLAGS@
# TCL_DEFS is not strictly need here, but if you remove it, then you
# must make sure that configure.ac checks for the necessary components
# that your library may use. TCL_DEFS can actually be a problem if
# you do not compile with a similar machine setup as the Tcl core was
# compiled with.
#DEFS = $(TCL_DEFS) @DEFS@ $(PKG_CFLAGS)
DEFS = @DEFS@ $(PKG_CFLAGS) -DTCL_NO_DEPRECATED=1
# Move pkgIndex.tcl to 'BINARIES' var if it is generated in the Makefile
CONFIG_CLEAN_FILES = Makefile pkgIndex.tcl
CLEANFILES = @CLEANFILES@
CPPFLAGS = @CPPFLAGS@
LIBS = @PKG_LIBS@ @LIBS@
AR = @AR@
CFLAGS = @CFLAGS@
LDFLAGS = @LDFLAGS@
LDFLAGS_DEFAULT = @LDFLAGS_DEFAULT@
COMPILE = $(CC) $(DEFS) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) \
$(CFLAGS_DEFAULT) $(CFLAGS_WARNING) $(SHLIB_CFLAGS) $(CFLAGS)
GDB = gdb
VALGRIND = valgrind
VALGRINDARGS = --tool=memcheck --num-callers=8 --leak-resolution=high \
--leak-check=yes --show-reachable=yes -v
.SUFFIXES: .c .$(OBJEXT)
#========================================================================
# Start of user-definable TARGETS section
#========================================================================
#========================================================================
# TEA TARGETS. Please note that the "libraries:" target refers to platform
# independent files, and the "binaries:" target includes executable programs and
# platform-dependent libraries. Modify these targets so that they install
# the various pieces of your package. The make and install rules
# for the BINARIES that you specified above have already been done.
#========================================================================
all: binaries libraries doc
#========================================================================
# The binaries target builds executable programs, Windows .dll's, unix
# shared/static libraries, and any other platform-dependent files.
# The list of targets to build for "binaries:" is specified at the top
# of the Makefile, in the "BINARIES" variable.
#========================================================================
binaries: $(BINARIES)
libraries:
#========================================================================
# Your doc target should differentiate from doc builds (by the developer)
# and doc installs (see install-doc), which just install the docs on the
# end user machine when building from source.
#========================================================================
doc:
install: all install-binaries install-libraries install-doc
install-binaries: binaries install-lib-binaries install-bin-binaries
#========================================================================
# This rule installs platform-independent files, such as header files.
# The list=...; for p in $$list handles the empty list case x-platform.
#========================================================================
install-libraries: libraries
@$(INSTALL_DATA_DIR) "$(DESTDIR)$(includedir)"
@echo "Installing header files in $(DESTDIR)$(includedir)"
@list='$(PKG_HEADERS)'; for i in $$list; do \
echo "Installing $(srcdir)/$$i" ; \
$(INSTALL_DATA) $(srcdir)/$$i "$(DESTDIR)$(includedir)" ; \
done;
#========================================================================
# Install documentation. Unix manpages should go in the $(mandir)
# directory.
#========================================================================
install-doc: doc
@$(INSTALL_DATA_DIR) "$(DESTDIR)$(mandir)/mann"
@echo "Installing documentation in $(DESTDIR)$(mandir)"
@list='$(srcdir)/doc/man/*.n'; for i in $$list; do \
echo "Installing $$i"; \
$(INSTALL_DATA) $$i "$(DESTDIR)$(mandir)/mann" ; \
done
test: binaries libraries
$(TCLSH) `@CYGPATH@ $(srcdir)/tests/all.tcl` $(TESTFLAGS) \
-load "package ifneeded Thread $(PACKAGE_VERSION) \
[list load `@CYGPATH@ $(PKG_LIB_FILE)` [string totitle $(PACKAGE_NAME)]]"
shell: binaries libraries
@$(TCLSH) $(SCRIPT)
gdb:
$(TCLSH_ENV) $(PKG_ENV) $(GDB) $(TCLSH_PROG) $(SCRIPT)
gdb-test: binaries libraries
$(TCLSH_ENV) $(PKG_ENV) $(GDB) \
--args $(TCLSH_PROG) `@CYGPATH@ $(srcdir)/tests/all.tcl` \
$(TESTFLAGS) -singleproc 1 \
-load "package ifneeded Thread $(PACKAGE_VERSION) \
[list load `@CYGPATH@ $(PKG_LIB_FILE)` [string totitle $(PACKAGE_NAME)]]"
valgrind: binaries libraries
$(TCLSH_ENV) $(PKG_ENV) $(VALGRIND) $(VALGRINDARGS) $(TCLSH_PROG) \
`@CYGPATH@ $(srcdir)/tests/all.tcl` $(TESTFLAGS)
valgrindshell: binaries libraries
$(TCLSH_ENV) $(PKG_ENV) $(VALGRIND) $(VALGRINDARGS) $(TCLSH_PROG) $(SCRIPT)
depend:
#========================================================================
# $(PKG_LIB_FILE) should be listed as part of the BINARIES variable
# mentioned above. That will ensure that this target is built when you
# run "make binaries".
#
# The $(PKG_OBJECTS) objects are created and linked into the final
# library. In most cases these object files will correspond to the
# source files above.
#========================================================================
$(PKG_LIB_FILE): $(PKG_OBJECTS)
-rm -f $(PKG_LIB_FILE)
${MAKE_LIB}
$(RANLIB) $(PKG_LIB_FILE)
$(PKG_STUB_LIB_FILE): $(PKG_STUB_OBJECTS)
-rm -f $(PKG_STUB_LIB_FILE)
${MAKE_STUB_LIB}
$(RANLIB_STUB) $(PKG_STUB_LIB_FILE)
#========================================================================
# We need to enumerate the list of .c to .o lines here.
#
# In the following lines, $(srcdir) refers to the toplevel directory
# containing your extension. If your sources are in a subdirectory,
# you will have to modify the paths to reflect this:
#
# sample.$(OBJEXT): $(srcdir)/generic/sample.c
# $(COMPILE) -c `@CYGPATH@ $(srcdir)/generic/sample.c` -o $@
#
# Setting the VPATH variable to a list of paths will cause the makefile
# to look into these paths when resolving .c to .obj dependencies.
# As necessary, add $(srcdir):$(srcdir)/compat:....
#========================================================================
VPATH = $(srcdir):$(srcdir)/generic:$(srcdir)/unix:$(srcdir)/win:$(srcdir)/macosx
.c.@OBJEXT@:
$(COMPILE) -c `@CYGPATH@ $<` -o $@
#========================================================================
# Distribution creation
# You may need to tweak this target to make it work correctly.
#========================================================================
#COMPRESS = tar cvf $(PKG_DIR).tar $(PKG_DIR); compress $(PKG_DIR).tar
COMPRESS = tar zcvf $(PKG_DIR).tar.gz $(PKG_DIR)
DIST_ROOT = /tmp/dist
DIST_DIR = $(DIST_ROOT)/$(PKG_DIR)
DIST_INSTALL_DATA = CPPROG='cp -p' $(INSTALL) -m 644
DIST_INSTALL_SCRIPT = CPPROG='cp -p' $(INSTALL) -m 755
dist-clean:
rm -rf $(DIST_DIR) $(DIST_ROOT)/$(PKG_DIR).tar.*
$(srcdir)/manifest.uuid:
printf "git-" >$(srcdir)/manifest.uuid
git rev-parse HEAD >>$(srcdir)/manifest.uuid
dist: dist-clean $(srcdir)/manifest.uuid
$(INSTALL_DATA_DIR) $(DIST_DIR)
$(DIST_INSTALL_DATA) $(srcdir)/license.terms \
$(srcdir)/manifest.uuid \
$(srcdir)/ChangeLog $(srcdir)/README \
$(srcdir)/aclocal.m4 $(srcdir)/configure.ac \
$(srcdir)/Makefile.in $(srcdir)/pkgIndex.tcl.in \
$(srcdir)/naviserver.m4 \
$(DIST_DIR)/
$(DIST_INSTALL_SCRIPT) $(srcdir)/configure $(DIST_DIR)/
$(INSTALL_DATA_DIR) $(DIST_DIR)/tclconfig
$(DIST_INSTALL_DATA) $(srcdir)/tclconfig/README.txt \
$(srcdir)/tclconfig/tcl.m4 $(srcdir)/tclconfig/install-sh \
$(DIST_DIR)/tclconfig/
$(INSTALL_DATA_DIR) $(DIST_DIR)/unix
$(DIST_INSTALL_DATA) $(srcdir)/unix/README $(srcdir)/unix/CONFIG \
$(srcdir)/unix/threadUnix.c \
$(DIST_DIR)/unix/
$(INSTALL_DATA_DIR) $(DIST_DIR)/win
$(DIST_INSTALL_DATA) \
$(srcdir)/win/README.txt $(srcdir)/win/CONFIG $(srcdir)/win/thread.rc \
$(srcdir)/win/makefile.vc \
$(srcdir)/win/nmakehlp.c $(srcdir)/win/pkg.vc \
$(srcdir)/win/targets.vc $(srcdir)/win/rules-ext.vc \
$(srcdir)/win/rules.vc $(srcdir)/win/thread_win.dsw \
$(srcdir)/win/thread_win.dsp \
$(DIST_DIR)/win/
$(INSTALL_DATA_DIR) $(DIST_DIR)/tcl
$(DIST_INSTALL_DATA) $(srcdir)/tcl/README $(DIST_DIR)/tcl/
list='tests doc doc/man doc/html generic lib tcl/cmdsrv tcl/phttpd tcl/tpool';\
for p in $$list; do \
if test -d $(srcdir)/$$p ; then \
$(INSTALL_DATA_DIR) $(DIST_DIR)/$$p; \
$(DIST_INSTALL_DATA) $(srcdir)/$$p/*.* $(DIST_DIR)/$$p/; \
fi; \
done
(cd $(DIST_ROOT); $(COMPRESS);)
#========================================================================
# End of user-definable section
#========================================================================
#========================================================================
# Don't modify the file to clean here. Instead, set the "CLEANFILES"
# variable in configure.ac
#========================================================================
clean:
-test -z "$(BINARIES)" || rm -f $(BINARIES)
-rm -f *.$(OBJEXT) core *.core
-test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
distclean: clean
-rm -f *.tab.c
-rm -f $(CONFIG_CLEAN_FILES)
-rm -f config.cache config.log config.status
#========================================================================
# Install binary object libraries. On Windows this includes both .dll and
# .lib files. Because the .lib files are not explicitly listed anywhere,
# we need to deduce their existence from the .dll file of the same name.
# Library files go into the lib directory.
# In addition, this will generate the pkgIndex.tcl
# file in the install location (assuming it can find a usable tclsh shell)
#
# You should not have to modify this target.
#========================================================================
install-lib-binaries: binaries
@$(INSTALL_DATA_DIR) "$(DESTDIR)$(pkglibdir)"
@list='$(lib_BINARIES)'; for p in $$list; do \
if test -f $$p; then \
echo " $(INSTALL_LIBRARY) $$p $(DESTDIR)$(pkglibdir)/$$p"; \
$(INSTALL_LIBRARY) $$p "$(DESTDIR)$(pkglibdir)/$$p"; \
stub=`echo $$p|sed -e "s/.*\(stub\).*/\1/"`; \
if test "x$$stub" = "xstub"; then \
echo " $(RANLIB_STUB) $(DESTDIR)$(pkglibdir)/$$p"; \
$(RANLIB_STUB) "$(DESTDIR)$(pkglibdir)/$$p"; \
else \
echo " $(RANLIB) $(DESTDIR)$(pkglibdir)/$$p"; \
$(RANLIB) "$(DESTDIR)$(pkglibdir)/$$p"; \
fi; \
ext=`echo $$p|sed -e "s/.*\.//"`; \
if test "x$$ext" = "xdll"; then \
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"; \
fi; \
fi; \
fi; \
done
@list='$(PKG_TCL_SOURCES)'; for p in $$list; do \
if test -f $(srcdir)/$$p; then \
destp=`basename $$p`; \
echo " Install $$destp $(DESTDIR)$(pkglibdir)/$$destp"; \
$(INSTALL_DATA) $(srcdir)/$$p "$(DESTDIR)$(pkglibdir)/$$destp"; \
fi; \
done
@if test "x$(SHARED_BUILD)" = "x1"; then \
echo " Install pkgIndex.tcl $(DESTDIR)$(pkglibdir)"; \
$(INSTALL_DATA) pkgIndex.tcl "$(DESTDIR)$(pkglibdir)"; \
fi
#========================================================================
# Install binary executables (e.g. .exe files and dependent .dll files)
# This is for files that must go in the bin directory (located next to
# wish and tclsh), like dependent .dll files on Windows.
#
# You should not have to modify this target, except to define bin_BINARIES
# above if necessary.
#========================================================================
install-bin-binaries: binaries
@$(INSTALL_DATA_DIR) "$(DESTDIR)$(bindir)"
@list='$(bin_BINARIES)'; for p in $$list; do \
if test -f $$p; then \
echo " $(INSTALL_PROGRAM) $$p $(DESTDIR)$(bindir)/$$p"; \
$(INSTALL_PROGRAM) $$p "$(DESTDIR)$(bindir)/$$p"; \
fi; \
done
Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
cd $(top_builddir) \
&& CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status
uninstall-binaries:
list='$(lib_BINARIES)'; for p in $$list; do \
rm -f "$(DESTDIR)$(pkglibdir)/$$p"; \
done
list='$(PKG_TCL_SOURCES)'; for p in $$list; do \
p=`basename $$p`; \
rm -f "$(DESTDIR)$(pkglibdir)/$$p"; \
done
list='$(bin_BINARIES)'; for p in $$list; do \
rm -f "$(DESTDIR)$(bindir)/$$p"; \
done
.PHONY: all binaries clean depend distclean doc install libraries test
.PHONY: gdb gdb-test valgrind valgrindshell
# Tell versions [3.59,3.63) of GNU make to not export all variables.
# Otherwise a system limit (for SysV at least) may be exceeded.
.NOEXPORT:

55
pkgs/thread2.8.7/README Normal file
View File

@@ -0,0 +1,55 @@
WHAT IS THIS ?
==============
This is the source distribution of the Tcl Thread extension.
You can use this extension to gain script-level access to Tcl
threading capabilities.
The extension can be used with Tcl cores starting from Tcl8.4 and later.
Also, this extension supports, i.e. can be used as a loadable module of,
AOLserver 4.x series of the highly-scalable web server from America Online.
You need to have your Tcl core compiled with "--enable-threads" in order
to turn on internal directives supporting thread-specific details of the
Tcl API. The extension will not load in an Tcl shell built w/o thread
support. Starting with Tcl 8.6, "--enable-threads" is already the default.
This extension is a freely available open source package. You can do
virtually anything you like with it, such as modifying it, redistributing
it, and selling it either in whole or in part. See the "license.terms"
file in the top-level distribution directory for complete information.
HOW TO COMPILE ?
================
Only Unix-like and Windows platforms are supported at the moment. Depending
on your platform (Unix-like or Windows) go to the appropriate directory
(unix or win) and start with the README file. Macintosh platform is supported
with the Mac OS X only. The Mac OS 9 (and previous) are not supported.
WHERE IS THE DOCUMENTATION ?
============================
Documentation in Unix man and standard HTML format is available in the
doc/man and doc/html directories respectively.
Currently, documentation is in reference-style only. The tutorial-style
documentation will be provided with future releases of the extension.
That is, if I ever get time to do that. Everybody is more than welcome
to jump in and help with the docs.
HOW TO GET SUPPORT ?
====================
The extension is maintained, enhanced, and distributed freely by the Tcl
community. The home for sources and bug/patch database is on fossil:
https://core.tcl-lang.org/thread
Alternatively, you are always welcome to post your questions, problems
and/or suggestions relating the extension (or any other Tcl issue)
to news:comp.lang.tcl newsgroup.
-EOF-

137
pkgs/thread2.8.7/aclocal.m4 vendored Normal file
View File

@@ -0,0 +1,137 @@
#
# Pull in the standard Tcl autoconf macros.
# If you don't have the "tclconfig" subdirectory, it is a dependent CVS
# module. Either "cvs -d <root> checkout tclconfig" right here, or
# re-checkout the thread module
#
builtin(include,tclconfig/tcl.m4)
builtin(include,naviserver.m4)
#
# Handle the "--with-gdbm" option for linking-in
# the gdbm-based peristent store for shared arrays.
# It tries to locate gdbm files in couple of standard
# system directories and/or common install locations
# in addition to the directory passed by the user.
# In the latter case, expect all gdbm lib files and
# include files located in the same directory.
#
AC_DEFUN(TCLTHREAD_WITH_GDBM, [
AC_ARG_WITH(gdbm,
[ --with-gdbm link with optional GDBM support],\
with_gdbm=${withval})
if test x"${with_gdbm}" != x -a "${with_gdbm}" != no; then
AC_MSG_CHECKING([for GNU gdbm library])
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
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
fi
fi
])
#
# Handle the "--with-lmdb" option for linking-in
# the LMDB-based peristent store for shared arrays.
# It tries to locate LMDB files in couple of standard
# system directories and/or common install locations
# in addition to the directory passed by the user.
# In the latter case, expect all LMDB lib files and
# include files located in the same directory.
#
AC_DEFUN(TCLTHREAD_WITH_LMDB, [
AC_ARG_WITH(lmdb,
[ --with-lmdb link with optional LMDB support],
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
fi
])
# EOF

15964
pkgs/thread2.8.7/configure vendored Normal file
View File

File diff suppressed because it is too large Load Diff

229
pkgs/thread2.8.7/configure.ac Normal file
View File

@@ -0,0 +1,229 @@
#!/bin/bash -norc
dnl This file is an input file used by the GNU "autoconf" program to
dnl generate the file "configure", which is run during Tcl installation
dnl to configure the system for the local environment.
#-----------------------------------------------------------------------
# Sample configure.ac for Tcl Extensions. The only places you should
# need to modify this file are marked by the string __CHANGE__
#-----------------------------------------------------------------------
#-----------------------------------------------------------------------
# __CHANGE__
# Set your package name and version numbers here.
#
# This initializes the environment with PACKAGE_NAME and PACKAGE_VERSION
# set as provided. These will also be added as -D defs in your Makefile
# so you can encode the package version directly into the source files.
#-----------------------------------------------------------------------
AC_INIT([thread],[2.8.7])
#--------------------------------------------------------------------
# Call TEA_INIT as the first TEA_ macro to set up initial vars.
# This will define a ${TEA_PLATFORM} variable == "unix" or "windows"
# as well as PKG_LIB_FILE and PKG_STUB_LIB_FILE.
#--------------------------------------------------------------------
TEA_INIT()
AC_CONFIG_AUX_DIR(tclconfig)
#--------------------------------------------------------------------
# Load the tclConfig.sh file
#--------------------------------------------------------------------
TEA_PATH_TCLCONFIG
TEA_LOAD_TCLCONFIG
if test "${TCL_MAJOR_VERSION}" -ne 8 ; then
AC_MSG_ERROR([${PACKAGE_NAME} ${PACKAGE_VERSION} requires Tcl 8.4+
Found config for Tcl ${TCL_VERSION}])
fi
if test "${TCL_MINOR_VERSION}" -lt 4 ; then
AC_MSG_ERROR([${PACKAGE_NAME} ${PACKAGE_VERSION} requires Tcl 8.4+
Found config for Tcl ${TCL_VERSION}])
fi
#--------------------------------------------------------------------
# Load the tkConfig.sh file if necessary (Tk extension)
#--------------------------------------------------------------------
#TEA_PATH_TKCONFIG
#TEA_LOAD_TKCONFIG
#-----------------------------------------------------------------------
# Handle the --prefix=... option by defaulting to what Tcl gave.
# Must be called after TEA_LOAD_TCLCONFIG and before TEA_SETUP_COMPILER.
#-----------------------------------------------------------------------
TEA_PREFIX
#-----------------------------------------------------------------------
# Standard compiler checks.
# This sets up CC by using the CC env var, or looks for gcc otherwise.
# This also calls AC_PROG_CC and a few others to create the basic setup
# necessary to compile executables.
#-----------------------------------------------------------------------
TEA_SETUP_COMPILER
#--------------------------------------------------------------------
# Check if building with optional Gdbm package. This will declare
# GDBM_CFLAGS and GDBM_LIBS variables.
#--------------------------------------------------------------------
TCLTHREAD_WITH_GDBM
#--------------------------------------------------------------------
# Check if building with optional lmdb package. This will declare
# LMDB_CFLAGS and LMDB_LIBS variables.
#--------------------------------------------------------------------
TCLTHREAD_WITH_LMDB
#--------------------------------------------------------------------
# Locate the NaviServer/AOLserver dir for compilation as NaviServer/AOLserver module.
# This will declare NS_INCLUDES, NS_LIBS and define NS_AOLSERVER.
#--------------------------------------------------------------------
NS_PATH_AOLSERVER
#-----------------------------------------------------------------------
# __CHANGE__
# Specify the C source files to compile in TEA_ADD_SOURCES,
# public headers that need to be installed in TEA_ADD_HEADERS,
# stub library C source files to compile in TEA_ADD_STUB_SOURCES,
# and runtime Tcl library files in TEA_ADD_TCL_SOURCES.
# This defines PKG(_STUB)_SOURCES, PKG(_STUB)_OBJECTS, PKG_HEADERS
# and PKG_TCL_SOURCES.
#-----------------------------------------------------------------------
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 \
])
TEA_ADD_HEADERS([generic/tclThread.h])
TEA_ADD_INCLUDES([${NS_INCLUDES}])
TEA_ADD_LIBS([${GDBM_LIBS} ${LMDB_LIBS} ${NS_LIBS}])
TEA_ADD_CFLAGS([${GDBM_CFLAGS} ${LMDB_CFLAGS}])
TEA_ADD_STUB_SOURCES([])
TEA_ADD_TCL_SOURCES([lib/ttrace.tcl])
#--------------------------------------------------------------------
# __CHANGE__
# A few miscellaneous platform-specific items:
#
# Define a special symbol for Windows (BUILD_sample in this case) so
# that we create the export library with the dll.
#
# Windows creates a few extra files that need to be cleaned up.
# You can add more files to clean if your extension creates any extra
# files.
#
# TEA_ADD_* any platform specific compiler/build info here.
#--------------------------------------------------------------------
if test "${TEA_PLATFORM}" = "windows" ; then
TEA_ADD_INCLUDES([-I\"$(${CYGPATH} ${srcdir}/win)\"])
else
TEA_ADD_SOURCES([unix/threadUnix.c])
fi
#--------------------------------------------------------------------
# __CHANGE__
# Choose which headers you need. Extension authors should try very
# hard to only rely on the Tcl public header files. Internal headers
# contain private data structures and are subject to change without
# notice.
# This MUST be called after TEA_LOAD_TCLCONFIG / TEA_LOAD_TKCONFIG
#--------------------------------------------------------------------
TEA_PUBLIC_TCL_HEADERS
#TEA_PRIVATE_TCL_HEADERS
#TEA_PUBLIC_TK_HEADERS
#TEA_PRIVATE_TK_HEADERS
#TEA_PATH_X
#--------------------------------------------------------------------
# Check whether --enable-threads or --disable-threads was given.
# This auto-enables if Tcl was compiled threaded.
#--------------------------------------------------------------------
TEA_ENABLE_THREADS
#--------------------------------------------------------------------
# The statement below defines a collection of symbols related to
# building as a shared library instead of a static library.
#--------------------------------------------------------------------
TEA_ENABLE_SHARED
#--------------------------------------------------------------------
# This macro figures out what flags to use with the compiler/linker
# when building shared/static debug/optimized objects. This information
# can be taken from the tclConfig.sh file, but this figures it all out.
#--------------------------------------------------------------------
TEA_CONFIG_CFLAGS
#--------------------------------------------------------------------
# Set the default compiler switches based on the --enable-symbols option.
#--------------------------------------------------------------------
TEA_ENABLE_SYMBOLS
#--------------------------------------------------------------------
# Everyone should be linking against the Tcl stub library. If you
# can't for some reason, remove this definition. If you aren't using
# stubs, you also need to modify the SHLIB_LD_LIBS setting below to
# link against the non-stubbed Tcl library. Add Tk too if necessary.
#--------------------------------------------------------------------
AC_DEFINE(USE_TCL_STUBS, 1, [Use Tcl stubs])
#--------------------------------------------------------------------
# Enable compile-time support for TIP #143 and TIP #285. When using
# a pre-Tcl 8.5 or 8.6 core, respectively, the actual functionality
# will not be available at runtime.
#--------------------------------------------------------------------
AC_DEFINE(TCL_TIP143, 1, [Enable TIP #143 support])
AC_DEFINE(TCL_TIP285, 1, [Enable TIP #285 support])
#--------------------------------------------------------------------
# This macro generates a line to use when building a library. It
# depends on values set by the TEA_ENABLE_SHARED, TEA_ENABLE_SYMBOLS,
# and TEA_LOAD_TCLCONFIG macros above.
#--------------------------------------------------------------------
TEA_MAKE_LIB
#--------------------------------------------------------------------
# Determine the name of the tclsh and/or wish executables in the
# Tcl and Tk build directories or the location they were installed
# into. These paths are used to support running test cases only,
# the Makefile should not be making use of these paths to generate
# a pkgIndex.tcl file or anything else at extension build time.
#--------------------------------------------------------------------
TEA_PROG_TCLSH
#TEA_PROG_WISH
#--------------------------------------------------------------------
# Finally, substitute all of the various values into the Makefile.
# You may alternatively have a special pkgIndex.tcl.in or other files
# which require substituting th AC variables in. Include these here.
#--------------------------------------------------------------------
AC_CONFIG_FILES([Makefile pkgIndex.tcl])
AC_OUTPUT

35
pkgs/thread2.8.7/doc/format.tcl Normal file
View File

@@ -0,0 +1,35 @@
#!/usr/local/bin/tclsh
set mydir [file dirname [info script]]
lappend auto_path /usr/local/lib
package req doctools
doctools::new dt
set wd [pwd]
cd $mydir
file rename html htm
set code [catch {
set f [open man.macros]
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
}
}
} err]
file rename htm html
cd $wd
if {$code} {
error $err
}
exit 0

604
pkgs/thread2.8.7/doc/html/thread.html Normal file
View File

@@ -0,0 +1,604 @@
<html><head>
<title>thread - Tcl Threading</title>
<style type="text/css"><!--
HTML {
background: #FFFFFF;
color: black;
}
BODY {
background: #FFFFFF;
color: black;
}
DIV.doctools {
margin-left: 10%;
margin-right: 10%;
}
DIV.doctools H1,DIV.doctools H2 {
margin-left: -5%;
}
H1, H2, H3, H4 {
margin-top: 1em;
font-family: sans-serif;
font-size: large;
color: #005A9C;
background: transparent;
text-align: left;
}
H1.doctools_title {
text-align: center;
}
UL,OL {
margin-right: 0em;
margin-top: 3pt;
margin-bottom: 3pt;
}
UL LI {
list-style: disc;
}
OL LI {
list-style: decimal;
}
DT {
padding-top: 1ex;
}
UL.doctools_toc,UL.doctools_toc UL, UL.doctools_toc UL UL {
font: normal 12pt/14pt sans-serif;
list-style: none;
}
LI.doctools_section, LI.doctools_subsection {
list-style: none;
margin-left: 0em;
text-indent: 0em;
padding: 0em;
}
PRE {
display: block;
font-family: monospace;
white-space: pre;
margin: 0%;
padding-top: 0.5ex;
padding-bottom: 0.5ex;
padding-left: 1ex;
padding-right: 1ex;
width: 100%;
}
PRE.doctools_example {
color: black;
background: #f5dcb3;
border: 1px solid black;
}
UL.doctools_requirements LI, UL.doctools_syntax LI {
list-style: none;
margin-left: 0em;
text-indent: 0em;
padding: 0em;
}
DIV.doctools_synopsis {
color: black;
background: #80ffff;
border: 1px solid black;
font-family: serif;
margin-top: 1em;
margin-bottom: 1em;
}
UL.doctools_syntax {
margin-top: 1em;
border-top: 1px solid black;
}
UL.doctools_requirements {
margin-bottom: 1em;
border-bottom: 1px solid black;
}
--></style>
</head>
<! -- Generated from file '' by tcllib/doctools with format 'html'
-->
<! -- thread.n
-->
<body><div class="doctools">
<h1 class="doctools_title">thread(n) 2.8 &quot;Tcl Threading&quot;</h1>
<div id="name" class="doctools_section"><h2><a name="name">Name</a></h2>
<p>thread - Extension for script access to Tcl threading</p>
</div>
<div id="toc" class="doctools_section"><h2><a name="toc">Table Of Contents</a></h2>
<ul class="doctools_toc">
<li class="doctools_section"><a href="#toc">Table Of Contents</a></li>
<li class="doctools_section"><a href="#synopsis">Synopsis</a></li>
<li class="doctools_section"><a href="#section1">Description</a></li>
<li class="doctools_section"><a href="#section2">COMMANDS</a></li>
<li class="doctools_section"><a href="#section3">DISCUSSION</a></li>
<li class="doctools_section"><a href="#see-also">See Also</a></li>
<li class="doctools_section"><a href="#keywords">Keywords</a></li>
</ul>
</div>
<div id="synopsis" class="doctools_section"><h2><a name="synopsis">Synopsis</a></h2>
<div class="doctools_synopsis">
<ul class="doctools_requirements">
<li>package require <b class="pkgname">Tcl 8.4</b></li>
<li>package require <b class="pkgname">Thread <span class="opt">?2.8?</span></b></li>
</ul>
<ul class="doctools_syntax">
<li><a href="#1"><b class="cmd">thread::create</b> <span class="opt">?-joinable?</span> <span class="opt">?-preserved?</span> <span class="opt">?script?</span></a></li>
<li><a href="#2"><b class="cmd">thread::preserve</b> <span class="opt">?id?</span></a></li>
<li><a href="#3"><b class="cmd">thread::release</b> <span class="opt">?-wait?</span> <span class="opt">?id?</span></a></li>
<li><a href="#4"><b class="cmd">thread::id</b></a></li>
<li><a href="#5"><b class="cmd">thread::errorproc</b> <span class="opt">?procname?</span></a></li>
<li><a href="#6"><b class="cmd">thread::cancel</b> <span class="opt">?-unwind?</span> <i class="arg">id</i> <span class="opt">?result?</span></a></li>
<li><a href="#7"><b class="cmd">thread::unwind</b></a></li>
<li><a href="#8"><b class="cmd">thread::exit</b> <span class="opt">?status?</span></a></li>
<li><a href="#9"><b class="cmd">thread::names</b></a></li>
<li><a href="#10"><b class="cmd">thread::exists</b> <i class="arg">id</i></a></li>
<li><a href="#11"><b class="cmd">thread::send</b> <span class="opt">?-async?</span> <span class="opt">?-head?</span> <i class="arg">id</i> <i class="arg">script</i> <span class="opt">?varname?</span></a></li>
<li><a href="#12"><b class="cmd">thread::broadcast</b> <i class="arg">script</i></a></li>
<li><a href="#13"><b class="cmd">thread::wait</b></a></li>
<li><a href="#14"><b class="cmd">thread::eval</b> <span class="opt">?-lock mutex?</span> <i class="arg">arg</i> <span class="opt">?arg ...?</span></a></li>
<li><a href="#15"><b class="cmd">thread::join</b> <i class="arg">id</i></a></li>
<li><a href="#16"><b class="cmd">thread::configure</b> <i class="arg">id</i> <span class="opt">?option?</span> <span class="opt">?value?</span> <span class="opt">?...?</span></a></li>
<li><a href="#17"><b class="cmd">thread::transfer</b> <i class="arg">id</i> <i class="arg">channel</i></a></li>
<li><a href="#18"><b class="cmd">thread::detach</b> <i class="arg">channel</i></a></li>
<li><a href="#19"><b class="cmd">thread::attach</b> <i class="arg">channel</i></a></li>
<li><a href="#20"><b class="cmd">thread::mutex</b></a></li>
<li><a href="#21"><b class="cmd">thread::mutex</b> <b class="method">create</b> <span class="opt">?-recursive?</span></a></li>
<li><a href="#22"><b class="cmd">thread::mutex</b> <b class="method">destroy</b> <i class="arg">mutex</i></a></li>
<li><a href="#23"><b class="cmd">thread::mutex</b> <b class="method">lock</b> <i class="arg">mutex</i></a></li>
<li><a href="#24"><b class="cmd">thread::mutex</b> <b class="method">unlock</b> <i class="arg">mutex</i></a></li>
<li><a href="#25"><b class="cmd">thread::rwmutex</b></a></li>
<li><a href="#26"><b class="cmd">thread::rwmutex</b> <b class="method">create</b></a></li>
<li><a href="#27"><b class="cmd">thread::rwmutex</b> <b class="method">destroy</b> <i class="arg">mutex</i></a></li>
<li><a href="#28"><b class="cmd">thread::rwmutex</b> <b class="method">rlock</b> <i class="arg">mutex</i></a></li>
<li><a href="#29"><b class="cmd">thread::rwmutex</b> <b class="method">wlock</b> <i class="arg">mutex</i></a></li>
<li><a href="#30"><b class="cmd">thread::rwmutex</b> <b class="method">unlock</b> <i class="arg">mutex</i></a></li>
<li><a href="#31"><b class="cmd">thread::cond</b></a></li>
<li><a href="#32"><b class="cmd">thread::cond</b> <b class="method">create</b></a></li>
<li><a href="#33"><b class="cmd">thread::cond</b> <b class="method">destroy</b> <i class="arg">cond</i></a></li>
<li><a href="#34"><b class="cmd">thread::cond</b> <b class="method">notify</b> <i class="arg">cond</i></a></li>
<li><a href="#35"><b class="cmd">thread::cond</b> <b class="method">wait</b> <i class="arg">cond</i> <i class="arg">mutex</i> <span class="opt">?ms?</span></a></li>
</ul>
</div>
</div>
<div id="section1" class="doctools_section"><h2><a name="section1">Description</a></h2>
<p>The <b class="package">thread</b> extension creates threads that contain Tcl
interpreters, and it lets you send scripts to those threads for
evaluation.
Additionaly, it provides script-level access to basic thread
synchronization primitives, like mutexes and condition variables.</p>
</div>
<div id="section2" class="doctools_section"><h2><a name="section2">COMMANDS</a></h2>
<p>This section describes commands for creating and destroying threads
and sending scripts to threads for evaluation.</p>
<dl class="doctools_definitions">
<dt><a name="1"><b class="cmd">thread::create</b> <span class="opt">?-joinable?</span> <span class="opt">?-preserved?</span> <span class="opt">?script?</span></a></dt>
<dd><p>This command creates a thread that contains a Tcl interpreter.
The Tcl interpreter either evaluates the optional <b class="option">script</b>, if
specified, or it waits in the event loop for scripts that arrive via
the <b class="cmd">thread::send</b> command. The result, if any, of the
optional <b class="option">script</b> is never returned to the caller.
The result of <b class="cmd">thread::create</b> is the ID of the thread. This is
the opaque handle which identifies the newly created thread for
all other package commands. The handle of the thread goes out of scope
automatically when thread is marked for exit
(see the <b class="cmd">thread::release</b> command below).</p>
<p>If the optional <b class="option">script</b> argument contains the <b class="cmd">thread::wait</b>
command the thread will enter into the event loop. If such command is not
found in the <b class="option">script</b> the thread will run the <b class="option">script</b> to
the end and exit. In that case, the handle may be safely ignored since it
refers to a thread which does not exists any more at the time when the
command returns.</p>
<p>Using flag <b class="option">-joinable</b> it is possible to create a joinable
thread, i.e. one upon whose exit can be waited upon by using
<b class="cmd">thread::join</b> command.
Note that failure to join a thread created with <b class="option">-joinable</b> flag
results in resource and memory leaks.</p>
<p>Threads created by the <b class="cmd">thread::create</b> cannot be destroyed
forcefully. Consequently, there is no corresponding thread destroy
command. A thread may only be released using the <b class="cmd">thread::release</b>
and if its internal reference count drops to zero, the thread is
marked for exit. This kicks the thread out of the event loop
servicing and the thread continues to execute commands passed in
the <b class="option">script</b> argument, following the <b class="cmd">thread::wait</b>
command. If this was the last command in the script, as usualy the
case, the thread will exit.</p>
<p>It is possible to create a situation in which it may be impossible
to terminate the thread, for example by putting some endless loop
after the <b class="cmd">thread::wait</b> or entering the event loop again by
doing an vwait-type of command. In such cases, the thread may never
exit. This is considered to be a bad practice and should be avoided
if possible. This is best illustrated by the example below:</p>
<pre class="doctools_example">
# You should never do ...
set tid [thread::create {
package require Http
thread::wait
vwait forever ; # &lt;-- this!
}]
</pre>
<p>The thread created in the above example will never be able to exit.
After it has been released with the last matching <b class="cmd">thread::release</b>
call, the thread will jump out of the <b class="cmd">thread::wait</b> and continue
to execute commands following. It will enter <b class="cmd">vwait</b> command and
wait endlessly for events. There is no way one can terminate such thread,
so you wouldn't want to do this!</p>
<p>Each newly created has its internal reference counter set to 0 (zero),
i.e. it is unreserved. This counter gets incremented by a call to
<b class="cmd">thread::preserve</b> and decremented by a call to <b class="cmd">thread::release</b>
command. These two commands implement simple but effective thread
reservation system and offer predictable and controllable thread
termination capabilities. It is however possible to create initialy
preserved threads by using flag <b class="option">-preserved</b> of the
<b class="cmd">thread::create</b> command. Threads created with this flag have the
initial value of the reference counter of 1 (one), and are thus
initially marked reserved.</p></dd>
<dt><a name="2"><b class="cmd">thread::preserve</b> <span class="opt">?id?</span></a></dt>
<dd><p>This command increments the thread reference counter. Each call
to this command increments the reference counter by one (1).
Command returns the value of the reference counter after the increment.
If called with the optional thread <b class="option">id</b>, the command preserves
the given thread. Otherwise the current thread is preserved.</p>
<p>With reference counting, one can implement controlled access to a
shared Tcl thread. By incrementing the reference counter, the
caller signalizes that he/she wishes to use the thread for a longer
period of time. By decrementing the counter, caller signalizes that
he/she has finished using the thread.</p></dd>
<dt><a name="3"><b class="cmd">thread::release</b> <span class="opt">?-wait?</span> <span class="opt">?id?</span></a></dt>
<dd><p>This command decrements the thread reference counter. Each call to
this command decrements the reference counter by one (1).
If called with the optional thread <b class="option">id</b>, the command releases
the given thread. Otherwise, the current thread is released.
Command returns the value of the reference counter after the decrement.
When the reference counter reaches zero (0), the target thread is
marked for termination. You should not reference the thread after the
<b class="cmd">thread::release</b> command returns zero or negative integer.
The handle of the thread goes out of scope and should not be used any
more. Any following reference to the same thread handle will result
in Tcl error.</p>
<p>Optional flag <b class="option">-wait</b> instructs the caller thread to wait for
the target thread to exit, if the effect of the command would result
in termination of the target thread, i.e. if the return result would
be zero (0). Without the flag, the caller thread does not wait for
the target thread to exit. Care must be taken when using the
<b class="option">-wait</b>, since this may block the caller thread indefinitely.
This option has been implemented for some special uses of the extension
and is deprecated for regular use. Regular users should create joinable
threads by using the <b class="option">-joinable</b> option of the <b class="cmd">thread::create</b>
command and the <b class="cmd">thread::join</b> to wait for thread to exit.</p></dd>
<dt><a name="4"><b class="cmd">thread::id</b></a></dt>
<dd><p>This command returns the ID of the current thread.</p></dd>
<dt><a name="5"><b class="cmd">thread::errorproc</b> <span class="opt">?procname?</span></a></dt>
<dd><p>This command sets a handler for errors that occur in scripts sent
asynchronously, using the <b class="option">-async</b> flag of the
<b class="cmd">thread::send</b> command, to other threads. If no handler
is specified, the current handler is returned. The empty string
resets the handler to default (unspecified) value.
An uncaught error in a thread causes an error message to be sent
to the standard error channel. This default reporting scheme can
be changed by registering a procedure which is called to report
the error. The <i class="arg">procname</i> is called in the interpreter that
invoked the <b class="cmd">thread::errorproc</b> command. The <i class="arg">procname</i>
is called like this:</p>
<pre class="doctools_example">
myerrorproc thread_id errorInfo
</pre>
</dd>
<dt><a name="6"><b class="cmd">thread::cancel</b> <span class="opt">?-unwind?</span> <i class="arg">id</i> <span class="opt">?result?</span></a></dt>
<dd><p>This command requires Tcl version 8.6 or higher.</p>
<p>Cancels the script being evaluated in the thread given by the <i class="arg">id</i>
parameter. Without the <b class="option">-unwind</b> switch the evaluation stack for
the interpreter is unwound until an enclosing catch command is found or
there are no further invocations of the interpreter left on the call
stack. With the <b class="option">-unwind</b> switch the evaluation stack for the
interpreter is unwound without regard to any intervening catch command
until there are no further invocations of the interpreter left on the
call stack. If <i class="arg">result</i> is present, it will be used as the error
message string; otherwise, a default error message string will be used.</p></dd>
<dt><a name="7"><b class="cmd">thread::unwind</b></a></dt>
<dd><p>Use of this command is deprecated in favour of more advanced thread
reservation system implemented with <b class="cmd">thread::preserve</b> and
<b class="cmd">thread::release</b> commands. Support for <b class="cmd">thread::unwind</b>
command will dissapear in some future major release of the extension.</p>
<p>This command stops a prior <b class="cmd">thread::wait</b> command. Execution of
the script passed to newly created thread will continue from the
<b class="cmd">thread::wait</b> command. If <b class="cmd">thread::wait</b> was the last command
in the script, the thread will exit. The command returns empty result
but may trigger Tcl error with the message &quot;target thread died&quot; in some
situations.</p></dd>
<dt><a name="8"><b class="cmd">thread::exit</b> <span class="opt">?status?</span></a></dt>
<dd><p>Use of this command is deprecated in favour of more advanced thread
reservation system implemented with <b class="cmd">thread::preserve</b> and
<b class="cmd">thread::release</b> commands. Support for <b class="cmd">thread::exit</b>
command will dissapear in some future major release of the extension.</p>
<p>This command forces a thread stuck in the <b class="cmd">thread::wait</b> command to
unconditionaly exit. The thread's exit status defaults to 666 and can be
specified using the optional <i class="arg">status</i> argument. The execution of
<b class="cmd">thread::exit</b> command is guaranteed to leave the program memory in the
unconsistent state, produce memory leaks and otherwise affect other subsytem(s)
of the Tcl application in an unpredictable manner. The command returns empty
result but may trigger Tcl error with the message &quot;target thread died&quot; in some
situations.</p></dd>
<dt><a name="9"><b class="cmd">thread::names</b></a></dt>
<dd><p>This command returns a list of thread IDs. These are only for
threads that have been created via <b class="cmd">thread::create</b> command.
If your application creates other threads at the C level, they
are not reported by this command.</p></dd>
<dt><a name="10"><b class="cmd">thread::exists</b> <i class="arg">id</i></a></dt>
<dd><p>Returns true (1) if thread given by the <i class="arg">id</i> parameter exists,
false (0) otherwise. This applies only for threads that have
been created via <b class="cmd">thread::create</b> command.</p></dd>
<dt><a name="11"><b class="cmd">thread::send</b> <span class="opt">?-async?</span> <span class="opt">?-head?</span> <i class="arg">id</i> <i class="arg">script</i> <span class="opt">?varname?</span></a></dt>
<dd><p>This command passes a <i class="arg">script</i> to another thread and, optionally,
waits for the result. If the <b class="option">-async</b> flag is specified, the
command does not wait for the result and it returns empty string.
The target thread must enter it's event loop in order to receive
scripts sent via this command. This is done by default for threads
created without a startup script. Threads can enter the event loop
explicitly by calling <b class="cmd">thread::wait</b> or any other relevant Tcl/Tk
command, like <b class="cmd">update</b>, <b class="cmd">vwait</b>, etc.</p>
<p>Optional <b class="option">varname</b> specifies name of the variable to store
the result of the <i class="arg">script</i>. Without the <b class="option">-async</b> flag,
the command returns the evaluation code, similarily to the standard
Tcl <b class="cmd">catch</b> command. If, however, the <b class="option">-async</b> flag is
specified, the command returns immediately and caller can later
<b class="cmd">vwait</b> on <span class="opt">?varname?</span> to get the result of the passed <i class="arg">script</i></p>
<pre class="doctools_example">
set t1 [thread::create]
set t2 [thread::create]
thread::send -async $t1 &quot;set a 1&quot; result
thread::send -async $t2 &quot;set b 2&quot; result
for {set i 0} {$i &lt; 2} {incr i} {
vwait result
}
</pre>
<p>In the above example, two threads were fed work and both of them were
instructed to signalize the same variable &quot;result&quot; in the calling thread.
The caller entered the event loop twice to get both results. Note,
however, that the order of the received results may vary, depending on
the current system load, type of work done, etc, etc.</p>
<p>Many threads can simultaneously send scripts to the target thread for
execution. All of them are entered into the event queue of the target
thread and executed on the FIFO basis, intermingled with optional other
events pending in the event queue of the target thread.
Using the optional <span class="opt">?-head?</span> switch, scripts posted to the thread's
event queue can be placed on the head, instead on the tail of the queue,
thus being executed in the LIFO fashion.</p></dd>
<dt><a name="12"><b class="cmd">thread::broadcast</b> <i class="arg">script</i></a></dt>
<dd><p>This command passes a <i class="arg">script</i> to all threads created by the
package for execution. It does not wait for response from any of
the threads.</p></dd>
<dt><a name="13"><b class="cmd">thread::wait</b></a></dt>
<dd><p>This enters the event loop so a thread can receive messages from
the <b class="cmd">thread::send</b> command. This command should only be used
within the script passed to the <b class="cmd">thread::create</b>. It should
be the very last command in the script. If this is not the case,
the exiting thread will continue executing the script lines past
the <b class="cmd">thread::wait</b> which is usually not what you want and/or
expect.</p>
<pre class="doctools_example">
set t1 [thread::create {
#
# Do some initialization work here
#
thread::wait ; # Enter the event loop
}]
</pre>
</dd>
<dt><a name="14"><b class="cmd">thread::eval</b> <span class="opt">?-lock mutex?</span> <i class="arg">arg</i> <span class="opt">?arg ...?</span></a></dt>
<dd><p>This command concatenates passed arguments and evaluates the
resulting script under the mutex protection. If no mutex is
specified by using the <span class="opt">?-lock mutex?</span> optional argument,
the internal static mutex is used.</p></dd>
<dt><a name="15"><b class="cmd">thread::join</b> <i class="arg">id</i></a></dt>
<dd><p>This command waits for the thread with ID <i class="arg">id</i> to exit and
then returns it's exit code. Errors will be returned for threads
which are not joinable or already waited upon by another thread.
Upon the join the handle of the thread has gone out of scope and
should not be used any more.</p></dd>
<dt><a name="16"><b class="cmd">thread::configure</b> <i class="arg">id</i> <span class="opt">?option?</span> <span class="opt">?value?</span> <span class="opt">?...?</span></a></dt>
<dd><p>This command configures various low-level aspects of the thread with
ID <i class="arg">id</i> in the similar way as the standard Tcl command
<b class="cmd">fconfigure</b> configures some Tcl channel options. Options currently
supported are: <b class="option">-eventmark</b> and <b class="option">-unwindonerror</b>.</p>
<p>The <b class="option">-eventmark</b> option, when set, limits the number of
asynchronously posted scripts to the thread event loop.
The <b class="cmd">thread::send -async</b> command will block until the number
of pending scripts in the event loop does not drop below the value
configured with <b class="option">-eventmark</b>. Default value for the
<b class="option">-eventmark</b> is 0 (zero) which effectively disables the checking,
i.e. allows for unlimited number of posted scripts.</p>
<p>The <b class="option">-unwindonerror</b> option, when set, causes the
target thread to unwind if the result of the script processing
resulted in error. Default value for the <b class="option">-unwindonerror</b>
is 0 (false), i.e. thread continues to process scripts after one
of the posted scripts fails.</p></dd>
<dt><a name="17"><b class="cmd">thread::transfer</b> <i class="arg">id</i> <i class="arg">channel</i></a></dt>
<dd><p>This moves the specified <i class="arg">channel</i> from the current thread
and interpreter to the main interpreter of the thread with the
given <i class="arg">id</i>. After the move the current interpreter has no
access to the channel any more, but the main interpreter of the
target thread will be able to use it from now on.
The command waits until the other thread has incorporated the
channel. Because of this it is possible to deadlock the
participating threads by commanding the other through a
synchronous <b class="cmd">thread::send</b> to transfer a channel to us.
This easily extends into longer loops of threads waiting for
each other. Other restrictions: the channel in question must
not be shared among multiple interpreters running in the
sending thread. This automatically excludes the special channels
for standard input, output and error.</p>
<p>Due to the internal Tcl core implementation and the restriction on
transferring shared channels, one has to take extra measures when
transferring socket channels created by accepting the connection
out of the <b class="cmd">socket</b> commands callback procedures:</p>
<pre class="doctools_example">
socket -server _Accept 2200
proc _Accept {s ipaddr port} {
after idle [list Accept $s $ipaddr $port]
}
proc Accept {s ipaddr port} {
set tid [thread::create]
thread::transfer $tid $s
}
</pre>
</dd>
<dt><a name="18"><b class="cmd">thread::detach</b> <i class="arg">channel</i></a></dt>
<dd><p>This detaches the specified <i class="arg">channel</i> from the current thread and
interpreter. After that, the current interpreter has no access to the
channel any more. The channel is in the parked state until some other
(or the same) thread attaches the channel again with <b class="cmd">thread::attach</b>.
Restrictions: same as for transferring shared channels with the
<b class="cmd">thread::transfer</b> command.</p></dd>
<dt><a name="19"><b class="cmd">thread::attach</b> <i class="arg">channel</i></a></dt>
<dd><p>This attaches the previously detached <i class="arg">channel</i> in the
current thread/interpreter. For already existing channels,
the command does nothing, i.e. it is not an error to attach the
same channel more than once. The first operation will actualy
perform the operation, while all subsequent operation will just
do nothing. Command throws error if the <i class="arg">channel</i> cannot be
found in the list of detached channels and/or in the current
interpreter.</p></dd>
<dt><a name="20"><b class="cmd">thread::mutex</b></a></dt>
<dd><p>Mutexes are most common thread synchronization primitives.
They are used to synchronize access from two or more threads to one or
more shared resources. This command provides script-level access to
exclusive and/or recursive mutexes. Exclusive mutexes can be locked
only once by one thread, while recursive mutexes can be locked many
times by the same thread. For recursive mutexes, number of lock and
unlock operations must match, otherwise, the mutex will never be
released, which would lead to various deadlock situations.</p>
<p>Care has to be taken when using mutexes in an multithreading program.
Improper use of mutexes may lead to various deadlock situations,
especially when using exclusive mutexes.</p>
<p>The <b class="cmd">thread::mutex</b> command supports following subcommands and options:</p>
<dl class="doctools_definitions">
<dt><a name="21"><b class="cmd">thread::mutex</b> <b class="method">create</b> <span class="opt">?-recursive?</span></a></dt>
<dd><p>Creates the mutex and returns it's opaque handle. This handle
should be used for any future reference to the newly created mutex.
If no optional <span class="opt">?-recursive?</span> argument was specified, the command
creates the exclusive mutex. With the <span class="opt">?-recursive?</span> argument,
the command creates a recursive mutex.</p></dd>
<dt><a name="22"><b class="cmd">thread::mutex</b> <b class="method">destroy</b> <i class="arg">mutex</i></a></dt>
<dd><p>Destroys the <i class="arg">mutex</i>. Mutex should be in unlocked state before
the destroy attempt. If the mutex is locked, the command will throw
Tcl error.</p></dd>
<dt><a name="23"><b class="cmd">thread::mutex</b> <b class="method">lock</b> <i class="arg">mutex</i></a></dt>
<dd><p>Locks the <i class="arg">mutex</i>. Locking the exclusive mutex may throw Tcl
error if on attempt to lock the same mutex twice from the same
thread. If your program logic forces you to lock the same mutex
twice or more from the same thread (this may happen in recursive
procedure invocations) you should consider using the recursive mutexes.</p></dd>
<dt><a name="24"><b class="cmd">thread::mutex</b> <b class="method">unlock</b> <i class="arg">mutex</i></a></dt>
<dd><p>Unlocks the <i class="arg">mutex</i> so some other thread may lock it again.
Attempt to unlock the already unlocked mutex will throw Tcl error.</p></dd>
</dl></dd>
<dt><a name="25"><b class="cmd">thread::rwmutex</b></a></dt>
<dd><p>This command creates many-readers/single-writer mutexes. Reader/writer
mutexes allow you to serialize access to a shared resource more optimally.
In situations where a shared resource gets mostly read and seldom modified,
you might gain some performace by using reader/writer mutexes instead of
exclusive or recursive mutexes.</p>
<p>For reading the resource, thread should obtain a read lock on the resource.
Read lock is non-exclusive, meaning that more than one thread can
obtain a read lock to the same resource, without waiting on other readers.
For changing the resource, however, a thread must obtain a exclusive
write lock. This lock effectively blocks all threads from gaining the
read-lock while the resource is been modified by the writer thread.
Only after the write lock has been released, the resource may be read-locked
again.</p>
<p>The <b class="cmd">thread::rwmutex</b> command supports following subcommands and options:</p>
<dl class="doctools_definitions">
<dt><a name="26"><b class="cmd">thread::rwmutex</b> <b class="method">create</b></a></dt>
<dd><p>Creates the reader/writer mutex and returns it's opaque handle.
This handle should be used for any future reference to the newly
created mutex.</p></dd>
<dt><a name="27"><b class="cmd">thread::rwmutex</b> <b class="method">destroy</b> <i class="arg">mutex</i></a></dt>
<dd><p>Destroys the reader/writer <i class="arg">mutex</i>. If the mutex is already locked,
attempt to destroy it will throw Tcl error.</p></dd>
<dt><a name="28"><b class="cmd">thread::rwmutex</b> <b class="method">rlock</b> <i class="arg">mutex</i></a></dt>
<dd><p>Locks the <i class="arg">mutex</i> for reading. More than one thread may read-lock
the same <i class="arg">mutex</i> at the same time.</p></dd>
<dt><a name="29"><b class="cmd">thread::rwmutex</b> <b class="method">wlock</b> <i class="arg">mutex</i></a></dt>
<dd><p>Locks the <i class="arg">mutex</i> for writing. Only one thread may write-lock
the same <i class="arg">mutex</i> at the same time. Attempt to write-lock same
<i class="arg">mutex</i> twice from the same thread will throw Tcl error.</p></dd>
<dt><a name="30"><b class="cmd">thread::rwmutex</b> <b class="method">unlock</b> <i class="arg">mutex</i></a></dt>
<dd><p>Unlocks the <i class="arg">mutex</i> so some other thread may lock it again.
Attempt to unlock already unlocked <i class="arg">mutex</i> will throw Tcl error.</p></dd>
</dl></dd>
<dt><a name="31"><b class="cmd">thread::cond</b></a></dt>
<dd><p>This command provides script-level access to condition variables.
A condition variable creates a safe environment for the program
to test some condition, sleep on it when false and be awakened
when it might have become true. A condition variable is always
used in the conjuction with an exclusive mutex. If you attempt
to use other type of mutex in conjuction with the condition
variable, a Tcl error will be thrown.</p>
<p>The command supports following subcommands and options:</p>
<dl class="doctools_definitions">
<dt><a name="32"><b class="cmd">thread::cond</b> <b class="method">create</b></a></dt>
<dd><p>Creates the condition variable and returns it's opaque handle.
This handle should be used for any future reference to newly
created condition variable.</p></dd>
<dt><a name="33"><b class="cmd">thread::cond</b> <b class="method">destroy</b> <i class="arg">cond</i></a></dt>
<dd><p>Destroys condition variable <i class="arg">cond</i>. Extreme care has to be taken
that nobody is using (i.e. waiting on) the condition variable,
otherwise unexpected errors may happen.</p></dd>
<dt><a name="34"><b class="cmd">thread::cond</b> <b class="method">notify</b> <i class="arg">cond</i></a></dt>
<dd><p>Wakes up all threads waiting on the condition variable <i class="arg">cond</i>.</p></dd>
<dt><a name="35"><b class="cmd">thread::cond</b> <b class="method">wait</b> <i class="arg">cond</i> <i class="arg">mutex</i> <span class="opt">?ms?</span></a></dt>
<dd><p>This command is used to suspend program execution until the condition
variable <i class="arg">cond</i> has been signalled or the optional timer has expired.
The exclusive <i class="arg">mutex</i> must be locked by the calling thread on entrance
to this command. If the mutex is not locked, Tcl error is thrown.
While waiting on the <i class="arg">cond</i>, the command releases <i class="arg">mutex</i>.
Before returning to the calling thread, the command re-acquires the
<i class="arg">mutex</i> again. Unlocking the <i class="arg">mutex</i> and waiting on the
condition variable <i class="arg">cond</i> is done atomically.</p>
<p>The <b class="option">ms</b> command option, if given, must be an integer specifying
time interval in milliseconds the command waits to be signalled.
Otherwise the command waits on condition notify forever.</p>
<p>In multithreading programs, there are many situations where a thread has
to wait for some event to happen until it is allowed to proceed.
This is usually accomplished by repeatedly testing a condition under the
mutex protection and waiting on the condition variable until the condition
evaluates to true:</p>
<pre class="doctools_example">
set mutex [thread::mutex create]
set cond [thread::cond create]
thread::mutex lock $mutex
while {&lt;some_condition_is_true&gt;} {
thread::cond wait $cond $mutex
}
# Do some work under mutex protection
thread::mutex unlock $mutex
</pre>
<p>Repeated testing of the condition is needed since the condition variable
may get signalled without the condition being actually changed (spurious
thread wake-ups, for example).</p></dd>
</dl></dd>
</dl>
</div>
<div id="section3" class="doctools_section"><h2><a name="section3">DISCUSSION</a></h2>
<p>The fundamental threading model in Tcl is that there can be one or
more Tcl interpreters per thread, but each Tcl interpreter should
only be used by a single thread which created it.
A &quot;shared memory&quot; abstraction is awkward to provide in Tcl because
Tcl makes assumptions about variable and data ownership. Therefore
this extension supports a simple form of threading where the main
thread can manage several background, or &quot;worker&quot; threads.
For example, an event-driven server can pass requests to worker
threads, and then await responses from worker threads or new client
requests. Everything goes through the common Tcl event loop, so
message passing between threads works naturally with event-driven I/O,
<b class="cmd">vwait</b> on variables, and so forth. For the transfer of bulk
information it is possible to move channels between the threads.</p>
<p>For advanced multithreading scripts, script-level access to two
basic synchronization primitives, mutex and condition variables,
is also supported.</p>
</div>
<div id="see-also" class="doctools_section"><h2><a name="see-also">See Also</a></h2>
<p><a href="http://www.tcl.tk/doc/howto/thread_model.html">http://www.tcl.tk/doc/howto/thread_model.html</a>, tpool, tsv, ttrace</p>
</div>
<div id="keywords" class="doctools_section"><h2><a name="keywords">Keywords</a></h2>
<p>events, message passing, mutex, synchronization, thread</p>
</div>
</div></body></html>

316
pkgs/thread2.8.7/doc/html/tpool.html Normal file
View File

@@ -0,0 +1,316 @@
<html><head>
<title>tpool - Tcl Threading</title>
<style type="text/css"><!--
HTML {
background: #FFFFFF;
color: black;
}
BODY {
background: #FFFFFF;
color: black;
}
DIV.doctools {
margin-left: 10%;
margin-right: 10%;
}
DIV.doctools H1,DIV.doctools H2 {
margin-left: -5%;
}
H1, H2, H3, H4 {
margin-top: 1em;
font-family: sans-serif;
font-size: large;
color: #005A9C;
background: transparent;
text-align: left;
}
H1.doctools_title {
text-align: center;
}
UL,OL {
margin-right: 0em;
margin-top: 3pt;
margin-bottom: 3pt;
}
UL LI {
list-style: disc;
}
OL LI {
list-style: decimal;
}
DT {
padding-top: 1ex;
}
UL.doctools_toc,UL.doctools_toc UL, UL.doctools_toc UL UL {
font: normal 12pt/14pt sans-serif;
list-style: none;
}
LI.doctools_section, LI.doctools_subsection {
list-style: none;
margin-left: 0em;
text-indent: 0em;
padding: 0em;
}
PRE {
display: block;
font-family: monospace;
white-space: pre;
margin: 0%;
padding-top: 0.5ex;
padding-bottom: 0.5ex;
padding-left: 1ex;
padding-right: 1ex;
width: 100%;
}
PRE.doctools_example {
color: black;
background: #f5dcb3;
border: 1px solid black;
}
UL.doctools_requirements LI, UL.doctools_syntax LI {
list-style: none;
margin-left: 0em;
text-indent: 0em;
padding: 0em;
}
DIV.doctools_synopsis {
color: black;
background: #80ffff;
border: 1px solid black;
font-family: serif;
margin-top: 1em;
margin-bottom: 1em;
}
UL.doctools_syntax {
margin-top: 1em;
border-top: 1px solid black;
}
UL.doctools_requirements {
margin-bottom: 1em;
border-bottom: 1px solid black;
}
--></style>
</head>
<! -- Generated from file '' by tcllib/doctools with format 'html'
-->
<! -- tpool.n
-->
<body><div class="doctools">
<h1 class="doctools_title">tpool(n) 2.8 &quot;Tcl Threading&quot;</h1>
<div id="name" class="doctools_section"><h2><a name="name">Name</a></h2>
<p>tpool - Part of the Tcl threading extension implementing pools of worker threads.</p>
</div>
<div id="toc" class="doctools_section"><h2><a name="toc">Table Of Contents</a></h2>
<ul class="doctools_toc">
<li class="doctools_section"><a href="#toc">Table Of Contents</a></li>
<li class="doctools_section"><a href="#synopsis">Synopsis</a></li>
<li class="doctools_section"><a href="#section1">Description</a></li>
<li class="doctools_section"><a href="#section2">COMMANDS</a></li>
<li class="doctools_section"><a href="#section3">DISCUSSION</a></li>
<li class="doctools_section"><a href="#see-also">See Also</a></li>
<li class="doctools_section"><a href="#keywords">Keywords</a></li>
</ul>
</div>
<div id="synopsis" class="doctools_section"><h2><a name="synopsis">Synopsis</a></h2>
<div class="doctools_synopsis">
<ul class="doctools_requirements">
<li>package require <b class="pkgname">Tcl 8.4</b></li>
<li>package require <b class="pkgname">Thread <span class="opt">?2.8?</span></b></li>
</ul>
<ul class="doctools_syntax">
<li><a href="#1"><b class="cmd">tpool::create</b> <span class="opt">?options?</span></a></li>
<li><a href="#2"><b class="cmd">tpool::names</b></a></li>
<li><a href="#3"><b class="cmd">tpool::post</b> <span class="opt">?-detached?</span> <span class="opt">?-nowait?</span> <i class="arg">tpool</i> <i class="arg">script</i></a></li>
<li><a href="#4"><b class="cmd">tpool::wait</b> <i class="arg">tpool</i> <i class="arg">joblist</i> <span class="opt">?varname?</span></a></li>
<li><a href="#5"><b class="cmd">tpool::cancel</b> <i class="arg">tpool</i> <i class="arg">joblist</i> <span class="opt">?varname?</span></a></li>
<li><a href="#6"><b class="cmd">tpool::get</b> <i class="arg">tpool</i> <i class="arg">job</i></a></li>
<li><a href="#7"><b class="cmd">tpool::preserve</b> <i class="arg">tpool</i></a></li>
<li><a href="#8"><b class="cmd">tpool::release</b> <i class="arg">tpool</i></a></li>
<li><a href="#9"><b class="cmd">tpool::suspend</b> <i class="arg">tpool</i></a></li>
<li><a href="#10"><b class="cmd">tpool::resume</b> <i class="arg">tpool</i></a></li>
</ul>
</div>
</div>
<div id="section1" class="doctools_section"><h2><a name="section1">Description</a></h2>
<p>This package creates and manages pools of worker threads. It allows you
to post jobs to worker threads and wait for their completion. The
threadpool implementation is Tcl event-loop aware. That means that any
time a caller is forced to wait for an event (job being completed or
a worker thread becoming idle or initialized), the implementation will
enter the event loop and allow for servicing of other pending file or
timer (or any other supported) events.</p>
</div>
<div id="section2" class="doctools_section"><h2><a name="section2">COMMANDS</a></h2>
<dl class="doctools_definitions">
<dt><a name="1"><b class="cmd">tpool::create</b> <span class="opt">?options?</span></a></dt>
<dd><p>This command creates new threadpool. It accepts several options as
key-value pairs. Options are used to tune some threadpool parameters.
The command returns the ID of the newly created threadpool.</p>
<p>Following options are supported:</p>
<dl class="doctools_options">
<dt><b class="option">-minworkers</b> <i class="arg">number</i></dt>
<dd><p>Minimum number of worker threads needed for this threadpool instance.
During threadpool creation, the implementation will create somany
worker threads upfront and will keep at least number of them alive
during the lifetime of the threadpool instance.
Default value of this parameter is 0 (zero). which means that a newly
threadpool will have no worker threads initialy. All worker threads
will be started on demand by callers running <b class="cmd">tpool::post</b> command
and posting jobs to the job queue.</p></dd>
<dt><b class="option">-maxworkers</b> <i class="arg">number</i></dt>
<dd><p>Maximum number of worker threads allowed for this threadpool instance.
If a new job is pending and there are no idle worker threads available,
the implementation will try to create new worker thread. If the number
of available worker threads is lower than the given number,
new worker thread will start. The caller will automatically enter the
event loop and wait until the worker thread has initialized. If. however,
the number of available worker threads is equal to the given number,
the caller will enter the event loop and wait for the first worker thread
to get idle, thus ready to run the job.
Default value of this parameter is 4 (four), which means that the
threadpool instance will allow maximum of 4 worker threads running jobs
or being idle waiting for new jobs to get posted to the job queue.</p></dd>
<dt><b class="option">-idletime</b> <i class="arg">seconds</i></dt>
<dd><p>Time in seconds an idle worker thread waits for the job to get posted
to the job queue. If no job arrives during this interval and the time
expires, the worker thread will check the number of currently available
worker threads and if the number is higher than the number set by the
<b class="option">minthreads</b> option, it will exit.
If an <b class="option">exitscript</b> has been defined, the exiting worker thread
will first run the script and then exit. Errors from the exit script,
if any, are ignored.</p>
<p>The idle worker thread is not servicing the event loop. If you, however,
put the worker thread into the event loop, by evaluating the
<b class="cmd">vwait</b> or other related Tcl commands, the worker thread
will not be in the idle state, hence the idle timer will not be
taken into account.
Default value for this option is unspecified.</p></dd>
<dt><b class="option">-initcmd</b> <i class="arg">script</i></dt>
<dd><p>Sets a Tcl script used to initialize new worker thread. This is usually
used to load packages and commands in the worker, set default variables,
create namespaces, and such. If the passed script runs into a Tcl error,
the worker will not be created and the initiating command (either the
<b class="cmd">tpool::create</b> or <b class="cmd">tpool::post</b>) will throw error.
Default value for this option is unspecified, hence, the Tcl interpreter of
the worker thread will contain just the initial set of Tcl commands.</p></dd>
<dt><b class="option">-exitcmd</b> <i class="arg">script</i></dt>
<dd><p>Sets a Tcl script run when the idle worker thread exits. This is normaly
used to cleanup the state of the worker thread, release reserved resources,
cleanup memory and such.
Default value for this option is unspecified, thus no Tcl script will run
on the worker thread exit.</p></dd>
</dl></dd>
<dt><a name="2"><b class="cmd">tpool::names</b></a></dt>
<dd><p>This command returns a list of IDs of threadpools created with the
<b class="cmd">tpool::create</b> command. If no threadpools were found, the
command will return empty list.</p></dd>
<dt><a name="3"><b class="cmd">tpool::post</b> <span class="opt">?-detached?</span> <span class="opt">?-nowait?</span> <i class="arg">tpool</i> <i class="arg">script</i></a></dt>
<dd><p>This command sends a <i class="arg">script</i> to the target <i class="arg">tpool</i> threadpool
for execution. The script will be executed in the first available idle
worker thread. If there are no idle worker threads available, the command
will create new one, enter the event loop and service events until the
newly created thread is initialized. If the current number of worker
threads is equal to the maximum number of worker threads, as defined
during the threadpool creation, the command will enter the event loop and
service events while waiting for one of the worker threads to become idle.
If the optional <span class="opt">?-nowait?</span> argument is given, the command will not wait
for one idle worker. It will just place the job in the pool's job queue
and return immediately.</p>
<p>The command returns the ID of the posted job. This ID is used for subsequent
<b class="cmd">tpool::wait</b>, <b class="cmd">tpool::get</b> and <b class="cmd">tpool::cancel</b> commands to wait
for and retrieve result of the posted script, or cancel the posted job
respectively. If the optional <span class="opt">?-detached?</span> argument is specified, the
command will post a detached job. A detached job can not be cancelled or
waited upon and is not identified by the job ID.</p>
<p>If the threadpool <i class="arg">tpool</i> is not found in the list of active
thread pools, the command will throw error. The error will also be triggered
if the newly created worker thread fails to initialize.</p></dd>
<dt><a name="4"><b class="cmd">tpool::wait</b> <i class="arg">tpool</i> <i class="arg">joblist</i> <span class="opt">?varname?</span></a></dt>
<dd><p>This command waits for one or many jobs, whose job IDs are given in the
<i class="arg">joblist</i> to get processed by the worker thread(s). If none of the
specified jobs are ready, the command will enter the event loop, service
events and wait for the first job to get ready.</p>
<p>The command returns the list of completed job IDs. If the optional variable
<span class="opt">?varname?</span> is given, it will be set to the list of jobs in the
<i class="arg">joblist</i> which are still pending. If the threadpool <i class="arg">tpool</i>
is not found in the list of active thread pools, the command will throw error.</p></dd>
<dt><a name="5"><b class="cmd">tpool::cancel</b> <i class="arg">tpool</i> <i class="arg">joblist</i> <span class="opt">?varname?</span></a></dt>
<dd><p>This command cancels the previously posted jobs given by the <i class="arg">joblist</i>
to the pool <i class="arg">tpool</i>. Job cancellation succeeds only for job still
waiting to be processed. If the job is already being executed by one of
the worker threads, the job will not be cancelled.
The command returns the list of cancelled job IDs. If the optional variable
<span class="opt">?varname?</span> is given, it will be set to the list of jobs in the
<i class="arg">joblist</i> which were not cancelled. If the threadpool <i class="arg">tpool</i>
is not found in the list of active thread pools, the command will throw error.</p></dd>
<dt><a name="6"><b class="cmd">tpool::get</b> <i class="arg">tpool</i> <i class="arg">job</i></a></dt>
<dd><p>This command retrieves the result of the previously posted <i class="arg">job</i>.
Only results of jobs waited upon with the <b class="cmd">tpool::wait</b> command
can be retrieved. If the execution of the script resulted in error,
the command will throw the error and update the <b class="variable">errorInfo</b> and
<b class="variable">errorCode</b> variables correspondingly. If the pool <i class="arg">tpool</i>
is not found in the list of threadpools, the command will throw error.
If the job <i class="arg">job</i> is not ready for retrieval, because it is currently
being executed by the worker thread, the command will throw error.</p></dd>
<dt><a name="7"><b class="cmd">tpool::preserve</b> <i class="arg">tpool</i></a></dt>
<dd><p>Each call to this command increments the reference counter of the
threadpool <i class="arg">tpool</i> by one (1). Command returns the value of the
reference counter after the increment.
By incrementing the reference counter, the caller signalizes that
he/she wishes to use the resource for a longer period of time.</p></dd>
<dt><a name="8"><b class="cmd">tpool::release</b> <i class="arg">tpool</i></a></dt>
<dd><p>Each call to this command decrements the reference counter of the
threadpool <i class="arg">tpool</i> by one (1).Command returns the value of the
reference counter after the decrement.
When the reference counter reaches zero (0), the threadpool <i class="arg">tpool</i>
is marked for termination. You should not reference the threadpool
after the <b class="cmd">tpool::release</b> command returns zero. The <i class="arg">tpool</i>
handle goes out of scope and should not be used any more. Any following
reference to the same threadpool handle will result in Tcl error.</p></dd>
<dt><a name="9"><b class="cmd">tpool::suspend</b> <i class="arg">tpool</i></a></dt>
<dd><p>Suspends processing work on this queue. All pool workers are paused
but additional work can be added to the pool. Note that adding the
additional work will not increase the number of workers dynamically
as the pool processing is suspended. Number of workers is maintained
to the count that was found prior suspending worker activity.
If you need to assure certain number of worker threads, use the
<b class="option">minworkers</b> option of the <b class="cmd">tpool::create</b> command.</p></dd>
<dt><a name="10"><b class="cmd">tpool::resume</b> <i class="arg">tpool</i></a></dt>
<dd><p>Resume processing work on this queue. All paused (suspended)
workers are free to get work from the pool. Note that resuming pool
operation will just let already created workers to proceed.
It will not create additional worker threads to handle the work
posted to the pool's work queue.</p></dd>
</dl>
</div>
<div id="section3" class="doctools_section"><h2><a name="section3">DISCUSSION</a></h2>
<p>Threadpool is one of the most common threading paradigm when it comes
to server applications handling a large number of relatively small tasks.
A very simplistic model for building a server application would be to
create a new thread each time a request arrives and service the request
in the new thread. One of the disadvantages of this approach is that
the overhead of creating a new thread for each request is significant;
a server that created a new thread for each request would spend more time
and consume more system resources in creating and destroying threads than
in processing actual user requests. In addition to the overhead of
creating and destroying threads, active threads consume system resources.
Creating too many threads can cause the system to run out of memory or
trash due to excessive memory consumption.</p>
<p>A thread pool offers a solution to both the problem of thread life-cycle
overhead and the problem of resource trashing. By reusing threads for
multiple tasks, the thread-creation overhead is spread over many tasks.
As a bonus, because the thread already exists when a request arrives,
the delay introduced by thread creation is eliminated. Thus, the request
can be serviced immediately. Furthermore, by properly tuning the number
of threads in the thread pool, resource thrashing may also be eliminated
by forcing any request to wait until a thread is available to process it.</p>
</div>
<div id="see-also" class="doctools_section"><h2><a name="see-also">See Also</a></h2>
<p>thread, tsv, ttrace</p>
</div>
<div id="keywords" class="doctools_section"><h2><a name="keywords">Keywords</a></h2>
<p>thread, threadpool</p>
</div>
</div></body></html>

409
pkgs/thread2.8.7/doc/html/tsv.html Normal file
View File

@@ -0,0 +1,409 @@
<html><head>
<title>tsv - Tcl Threading</title>
<style type="text/css"><!--
HTML {
background: #FFFFFF;
color: black;
}
BODY {
background: #FFFFFF;
color: black;
}
DIV.doctools {
margin-left: 10%;
margin-right: 10%;
}
DIV.doctools H1,DIV.doctools H2 {
margin-left: -5%;
}
H1, H2, H3, H4 {
margin-top: 1em;
font-family: sans-serif;
font-size: large;
color: #005A9C;
background: transparent;
text-align: left;
}
H1.doctools_title {
text-align: center;
}
UL,OL {
margin-right: 0em;
margin-top: 3pt;
margin-bottom: 3pt;
}
UL LI {
list-style: disc;
}
OL LI {
list-style: decimal;
}
DT {
padding-top: 1ex;
}
UL.doctools_toc,UL.doctools_toc UL, UL.doctools_toc UL UL {
font: normal 12pt/14pt sans-serif;
list-style: none;
}
LI.doctools_section, LI.doctools_subsection {
list-style: none;
margin-left: 0em;
text-indent: 0em;
padding: 0em;
}
PRE {
display: block;
font-family: monospace;
white-space: pre;
margin: 0%;
padding-top: 0.5ex;
padding-bottom: 0.5ex;
padding-left: 1ex;
padding-right: 1ex;
width: 100%;
}
PRE.doctools_example {
color: black;
background: #f5dcb3;
border: 1px solid black;
}
UL.doctools_requirements LI, UL.doctools_syntax LI {
list-style: none;
margin-left: 0em;
text-indent: 0em;
padding: 0em;
}
DIV.doctools_synopsis {
color: black;
background: #80ffff;
border: 1px solid black;
font-family: serif;
margin-top: 1em;
margin-bottom: 1em;
}
UL.doctools_syntax {
margin-top: 1em;
border-top: 1px solid black;
}
UL.doctools_requirements {
margin-bottom: 1em;
border-bottom: 1px solid black;
}
--></style>
</head>
<! -- Generated from file '' by tcllib/doctools with format 'html'
-->
<! -- tsv.n
-->
<body><div class="doctools">
<h1 class="doctools_title">tsv(n) 2.8 &quot;Tcl Threading&quot;</h1>
<div id="name" class="doctools_section"><h2><a name="name">Name</a></h2>
<p>tsv - Part of the Tcl threading extension allowing script level manipulation of data shared between threads.</p>
</div>
<div id="toc" class="doctools_section"><h2><a name="toc">Table Of Contents</a></h2>
<ul class="doctools_toc">
<li class="doctools_section"><a href="#toc">Table Of Contents</a></li>
<li class="doctools_section"><a href="#synopsis">Synopsis</a></li>
<li class="doctools_section"><a href="#section1">Description</a></li>
<li class="doctools_section"><a href="#section2">ELEMENT COMMANDS</a></li>
<li class="doctools_section"><a href="#section3">LIST COMMANDS</a></li>
<li class="doctools_section"><a href="#section4">ARRAY COMMANDS</a></li>
<li class="doctools_section"><a href="#section5">KEYED LIST COMMANDS</a></li>
<li class="doctools_section"><a href="#section6">DISCUSSION</a></li>
<li class="doctools_section"><a href="#section7">CREDITS</a></li>
<li class="doctools_section"><a href="#see-also">See Also</a></li>
<li class="doctools_section"><a href="#keywords">Keywords</a></li>
</ul>
</div>
<div id="synopsis" class="doctools_section"><h2><a name="synopsis">Synopsis</a></h2>
<div class="doctools_synopsis">
<ul class="doctools_requirements">
<li>package require <b class="pkgname">Tcl 8.4</b></li>
<li>package require <b class="pkgname">Thread <span class="opt">?2.8?</span></b></li>
</ul>
<ul class="doctools_syntax">
<li><a href="#1"><b class="cmd">tsv::names</b> <span class="opt">?pattern?</span></a></li>
<li><a href="#2"><b class="cmd">tsv::object</b> <i class="arg">varname</i> <i class="arg">element</i></a></li>
<li><a href="#3"><b class="cmd">tsv::set</b> <i class="arg">varname</i> <i class="arg">element</i> <span class="opt">?value?</span></a></li>
<li><a href="#4"><b class="cmd">tsv::get</b> <i class="arg">varname</i> <i class="arg">element</i> <span class="opt">?namedvar?</span></a></li>
<li><a href="#5"><b class="cmd">tsv::unset</b> <i class="arg">varname</i> <span class="opt">?element?</span></a></li>
<li><a href="#6"><b class="cmd">tsv::exists</b> <i class="arg">varname</i> <i class="arg">element</i></a></li>
<li><a href="#7"><b class="cmd">tsv::pop</b> <i class="arg">varname</i> <i class="arg">element</i></a></li>
<li><a href="#8"><b class="cmd">tsv::move</b> <i class="arg">varname</i> <i class="arg">oldname</i> <i class="arg">newname</i></a></li>
<li><a href="#9"><b class="cmd">tsv::incr</b> <i class="arg">varname</i> <i class="arg">element</i> <span class="opt">?count?</span></a></li>
<li><a href="#10"><b class="cmd">tsv::append</b> <i class="arg">varname</i> <i class="arg">element</i> <i class="arg">value</i> <span class="opt">?value ...?</span></a></li>
<li><a href="#11"><b class="cmd">tsv::lock</b> <i class="arg">varname</i> <i class="arg">arg</i> <span class="opt">?arg ...?</span></a></li>
<li><a href="#12"><b class="cmd">tsv::handlers</b></a></li>
<li><a href="#13"><b class="cmd">tsv::lappend</b> <i class="arg">varname</i> <i class="arg">element</i> <i class="arg">value</i> <span class="opt">?value ...?</span></a></li>
<li><a href="#14"><b class="cmd">tsv::linsert</b> <i class="arg">varname</i> <i class="arg">element</i> <i class="arg">index</i> <i class="arg">value</i> <span class="opt">?value ...?</span></a></li>
<li><a href="#15"><b class="cmd">tsv::lreplace</b> <i class="arg">varname</i> <i class="arg">element</i> <i class="arg">first</i> <i class="arg">last</i> <span class="opt">?value ...?</span></a></li>
<li><a href="#16"><b class="cmd">tsv::llength</b> <i class="arg">varname</i> <i class="arg">element</i></a></li>
<li><a href="#17"><b class="cmd">tsv::lindex</b> <i class="arg">varname</i> <i class="arg">element</i> <span class="opt">?index?</span></a></li>
<li><a href="#18"><b class="cmd">tsv::lrange</b> <i class="arg">varname</i> <i class="arg">element</i> <i class="arg">from</i> <i class="arg">to</i></a></li>
<li><a href="#19"><b class="cmd">tsv::lsearch</b> <i class="arg">varname</i> <i class="arg">element</i> <span class="opt">?options?</span> <i class="arg">pattern</i></a></li>
<li><a href="#20"><b class="cmd">tsv::lset</b> <i class="arg">varname</i> <i class="arg">element</i> <i class="arg">index</i> <span class="opt">?index ...?</span> <i class="arg">value</i></a></li>
<li><a href="#21"><b class="cmd">tsv::lpop</b> <i class="arg">varname</i> <i class="arg">element</i> <span class="opt">?index?</span></a></li>
<li><a href="#22"><b class="cmd">tsv::lpush</b> <i class="arg">varname</i> <i class="arg">element</i> <span class="opt">?index?</span></a></li>
<li><a href="#23"><b class="cmd">tsv::array set</b> <i class="arg">varname</i> <i class="arg">list</i></a></li>
<li><a href="#24"><b class="cmd">tsv::array get</b> <i class="arg">varname</i> <span class="opt">?pattern?</span></a></li>
<li><a href="#25"><b class="cmd">tsv::array names</b> <i class="arg">varname</i> <span class="opt">?pattern?</span></a></li>
<li><a href="#26"><b class="cmd">tsv::array size</b> <i class="arg">varname</i></a></li>
<li><a href="#27"><b class="cmd">tsv::array reset</b> <i class="arg">varname</i> <i class="arg">list</i></a></li>
<li><a href="#28"><b class="cmd">tsv::array bind</b> <i class="arg">varname</i> <i class="arg">handle</i></a></li>
<li><a href="#29"><b class="cmd">tsv::array unbind</b> <i class="arg">varname</i></a></li>
<li><a href="#30"><b class="cmd">tsv::array isbound</b> <i class="arg">varname</i></a></li>
<li><a href="#31"><b class="cmd">tsv::keyldel</b> <i class="arg">varname</i> <i class="arg">keylist</i> <i class="arg">key</i></a></li>
<li><a href="#32"><b class="cmd">tsv::keylget</b> <i class="arg">varname</i> <i class="arg">keylist</i> <i class="arg">key</i> <span class="opt">?retvar?</span></a></li>
<li><a href="#33"><b class="cmd">tsv::keylkeys</b> <i class="arg">varname</i> <i class="arg">keylist</i> <span class="opt">?key?</span></a></li>
<li><a href="#34"><b class="cmd">tsv::keylset</b> <i class="arg">varname</i> <i class="arg">keylist</i> <i class="arg">key</i> <i class="arg">value</i> <span class="opt">?key value..?</span></a></li>
</ul>
</div>
</div>
<div id="section1" class="doctools_section"><h2><a name="section1">Description</a></h2>
<p>This section describes commands implementing thread shared variables.
A thread shared variable is very similar to a Tcl array but in
contrast to a Tcl array it is created in shared memory and can
be accessed from many threads at the same time. Important feature of
thread shared variable is that each access to the variable is internaly
protected by a mutex so script programmer does not have to take care
about locking the variable himself.</p>
<p>Thread shared variables are not bound to any thread explicitly. That
means that when a thread which created any of thread shared variables
exits, the variable and associated memory is not unset/reclaimed.
User has to explicitly unset the variable to reclaim the memory
consumed by the variable.</p>
</div>
<div id="section2" class="doctools_section"><h2><a name="section2">ELEMENT COMMANDS</a></h2>
<dl class="doctools_definitions">
<dt><a name="1"><b class="cmd">tsv::names</b> <span class="opt">?pattern?</span></a></dt>
<dd><p>Returns names of shared variables matching optional <span class="opt">?pattern?</span>
or all known variables if pattern is ommited.</p></dd>
<dt><a name="2"><b class="cmd">tsv::object</b> <i class="arg">varname</i> <i class="arg">element</i></a></dt>
<dd><p>Creates object accessor command for the <i class="arg">element</i> in the
shared variable <i class="arg">varname</i>. Using this command, one can apply most
of the other shared variable commands as method functions of
the element object command. The object command is automatically
deleted when the element which this command is pointing to is unset.</p>
<pre class="doctools_example">
% tsv::set foo bar &quot;A shared string&quot;
% set string [tsv::object foo bar]
% $string append &quot; appended&quot;
=&gt; A shared string appended
</pre>
</dd>
<dt><a name="3"><b class="cmd">tsv::set</b> <i class="arg">varname</i> <i class="arg">element</i> <span class="opt">?value?</span></a></dt>
<dd><p>Sets the value of the <i class="arg">element</i> in the shared variable <i class="arg">varname</i>
to <i class="arg">value</i> and returns the value to caller. The <i class="arg">value</i>
may be ommited, in which case the command will return the current
value of the element. If the element cannot be found, error is triggered.</p></dd>
<dt><a name="4"><b class="cmd">tsv::get</b> <i class="arg">varname</i> <i class="arg">element</i> <span class="opt">?namedvar?</span></a></dt>
<dd><p>Retrieves the value of the <i class="arg">element</i> from the shared variable <i class="arg">varname</i>.
If the optional argument <i class="arg">namedvar</i> is given, the value is
stored in the named variable. Return value of the command depends
of the existence of the optional argument <i class="arg">namedvar</i>.
If the argument is ommited and the requested element cannot be found
in the shared array, the command triggers error. If, however, the
optional argument is given on the command line, the command returns
true (1) if the element is found or false (0) if the element is not found.</p></dd>
<dt><a name="5"><b class="cmd">tsv::unset</b> <i class="arg">varname</i> <span class="opt">?element?</span></a></dt>
<dd><p>Unsets the <i class="arg">element</i> from the shared variable <i class="arg">varname</i>.
If the optional element is not given, it deletes the variable.</p></dd>
<dt><a name="6"><b class="cmd">tsv::exists</b> <i class="arg">varname</i> <i class="arg">element</i></a></dt>
<dd><p>Checks wether the <i class="arg">element</i> exists in the shared variable <i class="arg">varname</i>
and returns true (1) if it does or false (0) if it doesn't.</p></dd>
<dt><a name="7"><b class="cmd">tsv::pop</b> <i class="arg">varname</i> <i class="arg">element</i></a></dt>
<dd><p>Returns value of the <i class="arg">element</i> in the shared variable <i class="arg">varname</i>
and unsets the element, all in one atomic operation.</p></dd>
<dt><a name="8"><b class="cmd">tsv::move</b> <i class="arg">varname</i> <i class="arg">oldname</i> <i class="arg">newname</i></a></dt>
<dd><p>Renames the element <i class="arg">oldname</i> to the <i class="arg">newname</i> in the
shared variable <i class="arg">varname</i>. This effectively performs an get/unset/set
sequence of operations but all in one atomic step.</p></dd>
<dt><a name="9"><b class="cmd">tsv::incr</b> <i class="arg">varname</i> <i class="arg">element</i> <span class="opt">?count?</span></a></dt>
<dd><p>Similar to standard Tcl <b class="cmd">incr</b> command but increments the value
of the <i class="arg">element</i> in shared variaboe <i class="arg">varname</i> instead of
the Tcl variable.</p></dd>
<dt><a name="10"><b class="cmd">tsv::append</b> <i class="arg">varname</i> <i class="arg">element</i> <i class="arg">value</i> <span class="opt">?value ...?</span></a></dt>
<dd><p>Similar to standard Tcl <b class="cmd">append</b> command but appends one or more
values to the <i class="arg">element</i> in shared variable <i class="arg">varname</i> instead of the
Tcl variable.</p></dd>
<dt><a name="11"><b class="cmd">tsv::lock</b> <i class="arg">varname</i> <i class="arg">arg</i> <span class="opt">?arg ...?</span></a></dt>
<dd><p>This command concatenates passed arguments and evaluates the
resulting script under the internal mutex protection. During the
script evaluation, the entire shared variable is locked. For shared
variable commands within the script, internal locking is disabled
so no deadlock can occur. It is also allowed to unset the shared
variable from within the script. The shared variable is automatically
created if it did not exists at the time of the first lock operation.</p>
<pre class="doctools_example">
% tsv::lock foo {
tsv::lappend foo bar 1
tsv::lappend foo bar 2
puts stderr [tsv::set foo bar]
tsv::unset foo
}
</pre>
</dd>
<dt><a name="12"><b class="cmd">tsv::handlers</b></a></dt>
<dd><p>Returns the names of all persistent storage handlers enabled at compile time.
See <span class="sectref"><a href="#section4">ARRAY COMMANDS</a></span> for details.</p></dd>
</dl>
</div>
<div id="section3" class="doctools_section"><h2><a name="section3">LIST COMMANDS</a></h2>
<p>Those command are similar to the equivalently named Tcl command. The difference
is that they operate on elements of shared arrays.</p>
<dl class="doctools_definitions">
<dt><a name="13"><b class="cmd">tsv::lappend</b> <i class="arg">varname</i> <i class="arg">element</i> <i class="arg">value</i> <span class="opt">?value ...?</span></a></dt>
<dd><p>Similar to standard Tcl <b class="cmd">lappend</b> command but appends one
or more values to the <i class="arg">element</i> in shared variable <i class="arg">varname</i>
instead of the Tcl variable.</p></dd>
<dt><a name="14"><b class="cmd">tsv::linsert</b> <i class="arg">varname</i> <i class="arg">element</i> <i class="arg">index</i> <i class="arg">value</i> <span class="opt">?value ...?</span></a></dt>
<dd><p>Similar to standard Tcl <b class="cmd">linsert</b> command but inserts one
or more values at the <i class="arg">index</i> list position in the
<i class="arg">element</i> in the shared variable <i class="arg">varname</i> instead of the Tcl variable.</p></dd>
<dt><a name="15"><b class="cmd">tsv::lreplace</b> <i class="arg">varname</i> <i class="arg">element</i> <i class="arg">first</i> <i class="arg">last</i> <span class="opt">?value ...?</span></a></dt>
<dd><p>Similar to standard Tcl <b class="cmd">lreplace</b> command but replaces one
or more values between the <i class="arg">first</i> and <i class="arg">last</i> position
in the <i class="arg">element</i> of the shared variable <i class="arg">varname</i> instead of
the Tcl variable.</p></dd>
<dt><a name="16"><b class="cmd">tsv::llength</b> <i class="arg">varname</i> <i class="arg">element</i></a></dt>
<dd><p>Similar to standard Tcl <b class="cmd">llength</b> command but returns length
of the <i class="arg">element</i> in the shared variable <i class="arg">varname</i> instead of the Tcl
variable.</p></dd>
<dt><a name="17"><b class="cmd">tsv::lindex</b> <i class="arg">varname</i> <i class="arg">element</i> <span class="opt">?index?</span></a></dt>
<dd><p>Similar to standard Tcl <b class="cmd">lindex</b> command but returns the value
at the <i class="arg">index</i> list position of the <i class="arg">element</i> from
the shared variable <i class="arg">varname</i> instead of the Tcl variable.</p></dd>
<dt><a name="18"><b class="cmd">tsv::lrange</b> <i class="arg">varname</i> <i class="arg">element</i> <i class="arg">from</i> <i class="arg">to</i></a></dt>
<dd><p>Similar to standard Tcl <b class="cmd">lrange</b> command but returns values
between <i class="arg">from</i> and <i class="arg">to</i> list positions from the
<i class="arg">element</i> in the shared variable <i class="arg">varname</i> instead of the Tcl variable.</p></dd>
<dt><a name="19"><b class="cmd">tsv::lsearch</b> <i class="arg">varname</i> <i class="arg">element</i> <span class="opt">?options?</span> <i class="arg">pattern</i></a></dt>
<dd><p>Similar to standard Tcl <b class="cmd">lsearch</b> command but searches the <i class="arg">element</i>
in the shared variable <i class="arg">varname</i> instead of the Tcl variable.</p></dd>
<dt><a name="20"><b class="cmd">tsv::lset</b> <i class="arg">varname</i> <i class="arg">element</i> <i class="arg">index</i> <span class="opt">?index ...?</span> <i class="arg">value</i></a></dt>
<dd><p>Similar to standard Tcl <b class="cmd">lset</b> command but sets the <i class="arg">element</i>
in the shared variable <i class="arg">varname</i> instead of the Tcl variable.</p></dd>
<dt><a name="21"><b class="cmd">tsv::lpop</b> <i class="arg">varname</i> <i class="arg">element</i> <span class="opt">?index?</span></a></dt>
<dd><p>Similar to the standard Tcl <b class="cmd">lindex</b> command but in addition to
returning, it also splices the value out of the <i class="arg">element</i>
from the shared variable <i class="arg">varname</i> in one atomic operation.
In contrast to the Tcl <b class="cmd">lindex</b> command, this command returns
no value to the caller.</p></dd>
<dt><a name="22"><b class="cmd">tsv::lpush</b> <i class="arg">varname</i> <i class="arg">element</i> <span class="opt">?index?</span></a></dt>
<dd><p>This command performes the opposite of the <b class="cmd">tsv::lpop</b> command.
As its counterpart, it returns no value to the caller.</p></dd>
</dl>
</div>
<div id="section4" class="doctools_section"><h2><a name="section4">ARRAY COMMANDS</a></h2>
<p>This command supports most of the options of the standard Tcl
<b class="cmd">array</b> command. In addition to those, it allows binding
a shared variable to some persisten storage databases. Currently the persistent
options supported are the famous GNU Gdbm and LMDB. These options have to be
selected during the package compilation time.
The implementation provides hooks for defining other persistency layers, if
needed.</p>
<dl class="doctools_definitions">
<dt><a name="23"><b class="cmd">tsv::array set</b> <i class="arg">varname</i> <i class="arg">list</i></a></dt>
<dd><p>Does the same as standard Tcl <b class="cmd">array set</b>.</p></dd>
<dt><a name="24"><b class="cmd">tsv::array get</b> <i class="arg">varname</i> <span class="opt">?pattern?</span></a></dt>
<dd><p>Does the same as standard Tcl <b class="cmd">array get</b>.</p></dd>
<dt><a name="25"><b class="cmd">tsv::array names</b> <i class="arg">varname</i> <span class="opt">?pattern?</span></a></dt>
<dd><p>Does the same as standard Tcl <b class="cmd">array names</b>.</p></dd>
<dt><a name="26"><b class="cmd">tsv::array size</b> <i class="arg">varname</i></a></dt>
<dd><p>Does the same as standard Tcl <b class="cmd">array size</b>.</p></dd>
<dt><a name="27"><b class="cmd">tsv::array reset</b> <i class="arg">varname</i> <i class="arg">list</i></a></dt>
<dd><p>Does the same as standard Tcl <b class="cmd">array set</b> but it clears
the <i class="arg">varname</i> and sets new values from the list atomically.</p></dd>
<dt><a name="28"><b class="cmd">tsv::array bind</b> <i class="arg">varname</i> <i class="arg">handle</i></a></dt>
<dd><p>Binds the <i class="arg">varname</i> to the persistent storage <i class="arg">handle</i>.
The format of the <i class="arg">handle</i> is &lt;handler&gt;:&lt;address&gt;, where &lt;handler&gt; is
&quot;gdbm&quot; for GNU Gdbm and &quot;lmdb&quot; for LMDB and &lt;address&gt; is the path to the
database file.</p></dd>
<dt><a name="29"><b class="cmd">tsv::array unbind</b> <i class="arg">varname</i></a></dt>
<dd><p>Unbinds the shared <i class="arg">array</i> from its bound persistent storage.</p></dd>
<dt><a name="30"><b class="cmd">tsv::array isbound</b> <i class="arg">varname</i></a></dt>
<dd><p>Returns true (1) if the shared <i class="arg">varname</i> is bound to some
persistent storage or zero (0) if not.</p></dd>
</dl>
</div>
<div id="section5" class="doctools_section"><h2><a name="section5">KEYED LIST COMMANDS</a></h2>
<p>Keyed list commands are borrowed from the TclX package. Keyed lists provide
a structured data type built upon standard Tcl lists. This is a functionality
similar to structs in the C programming language.</p>
<p>A keyed list is a list in which each element contains a key and value
pair. These element pairs are stored as lists themselves, where the key
is the first element of the list, and the value is the second. The
key-value pairs are referred to as fields. This is an example of a
keyed list:</p>
<pre class="doctools_example">
{{NAME {Frank Zappa}} {JOB {musician and composer}}}
</pre>
<p>Fields may contain subfields; `.' is the separator character. Subfields
are actually fields where the value is another keyed list. Thus the
following list has the top level fields ID and NAME, and subfields
NAME.FIRST and NAME.LAST:</p>
<pre class="doctools_example">
{ID 106} {NAME {{FIRST Frank} {LAST Zappa}}}
</pre>
<p>There is no limit to the recursive depth of subfields,
allowing one to build complex data structures. Keyed lists are constructed
and accessed via a number of commands. All keyed list management
commands take the name of the variable containing the keyed list as an
argument (i.e. passed by reference), rather than passing the list directly.</p>
<dl class="doctools_definitions">
<dt><a name="31"><b class="cmd">tsv::keyldel</b> <i class="arg">varname</i> <i class="arg">keylist</i> <i class="arg">key</i></a></dt>
<dd><p>Delete the field specified by <i class="arg">key</i> from the keyed list <i class="arg">keylist</i>
in the shared variable <i class="arg">varname</i>.
This removes both the key and the value from the keyed list.</p></dd>
<dt><a name="32"><b class="cmd">tsv::keylget</b> <i class="arg">varname</i> <i class="arg">keylist</i> <i class="arg">key</i> <span class="opt">?retvar?</span></a></dt>
<dd><p>Return the value associated with <i class="arg">key</i> from the keyed list <i class="arg">keylist</i>
in the shared variable <i class="arg">varname</i>.
If the optional <i class="arg">retvar</i> is not specified, then the value will be
returned as the result of the command. In this case, if key is not found
in the list, an error will result.</p>
<p>If <i class="arg">retvar</i> is specified and <i class="arg">key</i> is in the list, then the value
is returned in the variable <i class="arg">retvar</i> and the command returns 1 if the
key was present within the list. If <i class="arg">key</i> isn't in the list, the
command will return 0, and <i class="arg">retvar</i> will be left unchanged. If {} is
specified for <i class="arg">retvar</i>, the value is not returned, allowing the Tcl
programmer to determine if a <i class="arg">key</i> is present in a keyed list without
setting a variable as a side-effect.</p></dd>
<dt><a name="33"><b class="cmd">tsv::keylkeys</b> <i class="arg">varname</i> <i class="arg">keylist</i> <span class="opt">?key?</span></a></dt>
<dd><p>Return the a list of the keys in the keyed list <i class="arg">keylist</i> in the
shared variable <i class="arg">varname</i>. If <i class="arg">key</i> is specified, then it is
the name of a key field who's subfield keys are to be retrieved.</p></dd>
<dt><a name="34"><b class="cmd">tsv::keylset</b> <i class="arg">varname</i> <i class="arg">keylist</i> <i class="arg">key</i> <i class="arg">value</i> <span class="opt">?key value..?</span></a></dt>
<dd><p>Set the value associated with <i class="arg">key</i>, in the keyed list <i class="arg">keylist</i>
to <i class="arg">value</i>. If the <i class="arg">keylist</i> does not exists, it is created.
If <i class="arg">key</i> is not currently in the list, it will be added. If it already
exists, <i class="arg">value</i> replaces the existing value. Multiple keywords and
values may be specified, if desired.</p></dd>
</dl>
</div>
<div id="section6" class="doctools_section"><h2><a name="section6">DISCUSSION</a></h2>
<p>The current implementation of thread shared variables allows for easy and
convenient access to data shared between different threads.
Internally, the data is stored in Tcl objects and all package commands
operate on internal data representation, thus minimizing shimmering and
improving performance. Special care has been taken to assure that all
object data is properly locked and deep-copied when moving objects between
threads.</p>
<p>Due to the internal design of the Tcl core, there is no provision of full
integration of shared variables within the Tcl syntax, unfortunately. All
access to shared data must be performed with the supplied package commands.
Also, variable traces are not supported. But even so, benefits of easy,
simple and safe shared data manipulation outweights imposed limitations.</p>
</div>
<div id="section7" class="doctools_section"><h2><a name="section7">CREDITS</a></h2>
<p>Thread shared variables are inspired by the nsv interface found in
AOLserver, a highly scalable Web server from America Online.</p>
</div>
<div id="see-also" class="doctools_section"><h2><a name="see-also">See Also</a></h2>
<p>thread, tpool, ttrace</p>
</div>
<div id="keywords" class="doctools_section"><h2><a name="keywords">Keywords</a></h2>
<p>locking, synchronization, thread shared data, threads</p>
</div>
</div></body></html>

312
pkgs/thread2.8.7/doc/html/ttrace.html Normal file
View File

@@ -0,0 +1,312 @@
<html><head>
<title>ttrace - Tcl Threading</title>
<style type="text/css"><!--
HTML {
background: #FFFFFF;
color: black;
}
BODY {
background: #FFFFFF;
color: black;
}
DIV.doctools {
margin-left: 10%;
margin-right: 10%;
}
DIV.doctools H1,DIV.doctools H2 {
margin-left: -5%;
}
H1, H2, H3, H4 {
margin-top: 1em;
font-family: sans-serif;
font-size: large;
color: #005A9C;
background: transparent;
text-align: left;
}
H1.doctools_title {
text-align: center;
}
UL,OL {
margin-right: 0em;
margin-top: 3pt;
margin-bottom: 3pt;
}
UL LI {
list-style: disc;
}
OL LI {
list-style: decimal;
}
DT {
padding-top: 1ex;
}
UL.doctools_toc,UL.doctools_toc UL, UL.doctools_toc UL UL {
font: normal 12pt/14pt sans-serif;
list-style: none;
}
LI.doctools_section, LI.doctools_subsection {
list-style: none;
margin-left: 0em;
text-indent: 0em;
padding: 0em;
}
PRE {
display: block;
font-family: monospace;
white-space: pre;
margin: 0%;
padding-top: 0.5ex;
padding-bottom: 0.5ex;
padding-left: 1ex;
padding-right: 1ex;
width: 100%;
}
PRE.doctools_example {
color: black;
background: #f5dcb3;
border: 1px solid black;
}
UL.doctools_requirements LI, UL.doctools_syntax LI {
list-style: none;
margin-left: 0em;
text-indent: 0em;
padding: 0em;
}
DIV.doctools_synopsis {
color: black;
background: #80ffff;
border: 1px solid black;
font-family: serif;
margin-top: 1em;
margin-bottom: 1em;
}
UL.doctools_syntax {
margin-top: 1em;
border-top: 1px solid black;
}
UL.doctools_requirements {
margin-bottom: 1em;
border-bottom: 1px solid black;
}
--></style>
</head>
<! -- Generated from file '' by tcllib/doctools with format 'html'
-->
<! -- ttrace.n
-->
<body><div class="doctools">
<h1 class="doctools_title">ttrace(n) 2.8 &quot;Tcl Threading&quot;</h1>
<div id="name" class="doctools_section"><h2><a name="name">Name</a></h2>
<p>ttrace - Trace-based interpreter initialization</p>
</div>
<div id="toc" class="doctools_section"><h2><a name="toc">Table Of Contents</a></h2>
<ul class="doctools_toc">
<li class="doctools_section"><a href="#toc">Table Of Contents</a></li>
<li class="doctools_section"><a href="#synopsis">Synopsis</a></li>
<li class="doctools_section"><a href="#section1">Description</a></li>
<li class="doctools_section"><a href="#section2">USER COMMANDS</a></li>
<li class="doctools_section"><a href="#section3">CALLBACK COMMANDS</a></li>
<li class="doctools_section"><a href="#section4">DISCUSSION</a></li>
<li class="doctools_section"><a href="#see-also">See Also</a></li>
<li class="doctools_section"><a href="#keywords">Keywords</a></li>
</ul>
</div>
<div id="synopsis" class="doctools_section"><h2><a name="synopsis">Synopsis</a></h2>
<div class="doctools_synopsis">
<ul class="doctools_requirements">
<li>package require <b class="pkgname">Tcl 8.4</b></li>
<li>package require <b class="pkgname">Thread <span class="opt">?2.8?</span></b></li>
</ul>
<ul class="doctools_syntax">
<li><a href="#1"><b class="cmd">ttrace::eval</b> <i class="arg">arg</i> <span class="opt">?arg ...?</span></a></li>
<li><a href="#2"><b class="cmd">ttrace::enable</b></a></li>
<li><a href="#3"><b class="cmd">ttrace::disable</b></a></li>
<li><a href="#4"><b class="cmd">ttrace::cleanup</b></a></li>
<li><a href="#5"><b class="cmd">ttrace::update</b> <span class="opt">?epoch?</span></a></li>
<li><a href="#6"><b class="cmd">ttrace::getscript</b></a></li>
<li><a href="#7"><b class="cmd">ttrace::atenable</b> <i class="arg">cmd</i> <i class="arg">arglist</i> <i class="arg">body</i></a></li>
<li><a href="#8"><b class="cmd">ttrace::atdisable</b> <i class="arg">cmd</i> <i class="arg">arglist</i> <i class="arg">body</i></a></li>
<li><a href="#9"><b class="cmd">ttrace::addtrace</b> <i class="arg">cmd</i> <i class="arg">arglist</i> <i class="arg">body</i></a></li>
<li><a href="#10"><b class="cmd">ttrace::addscript</b> <i class="arg">name</i> <i class="arg">body</i></a></li>
<li><a href="#11"><b class="cmd">ttrace::addresolver</b> <i class="arg">cmd</i> <i class="arg">arglist</i> <i class="arg">body</i></a></li>
<li><a href="#12"><b class="cmd">ttrace::addcleanup</b> <i class="arg">body</i></a></li>
<li><a href="#13"><b class="cmd">ttrace::addentry</b> <i class="arg">cmd</i> <i class="arg">var</i> <i class="arg">val</i></a></li>
<li><a href="#14"><b class="cmd">ttrace::getentry</b> <i class="arg">cmd</i> <i class="arg">var</i></a></li>
<li><a href="#15"><b class="cmd">ttrace::getentries</b> <i class="arg">cmd</i> <span class="opt">?pattern?</span></a></li>
<li><a href="#16"><b class="cmd">ttrace::delentry</b> <i class="arg">cmd</i></a></li>
<li><a href="#17"><b class="cmd">ttrace::preload</b> <i class="arg">cmd</i></a></li>
</ul>
</div>
</div>
<div id="section1" class="doctools_section"><h2><a name="section1">Description</a></h2>
<p>This package creates a framework for on-demand replication of the
interpreter state accross threads in an multithreading application.
It relies on the mechanics of Tcl command tracing and the Tcl
<b class="cmd">unknown</b> command and mechanism.</p>
<p>The package requires Tcl threading extension but can be alternatively
used stand-alone within the AOLserver, a scalable webserver from
America Online.</p>
<p>In a nutshell, a short sample illustrating the usage of the ttrace
with the Tcl threading extension:</p>
<pre class="doctools_example">
% package require Ttrace
2.8.2
% set t1 [thread::create {package require Ttrace; thread::wait}]
tid0x1802800
% ttrace::eval {proc test args {return test-[thread::id]}}
% thread::send $t1 test
test-tid0x1802800
% set t2 [thread::create {package require Ttrace; thread::wait}]
tid0x1804000
% thread::send $t2 test
test-tid0x1804000
</pre>
<p>As seen from above, the <b class="cmd">ttrace::eval</b> and <b class="cmd">ttrace::update</b>
commands are used to create a thread-wide definition of a simple
Tcl procedure and replicate that definition to all, already existing
or later created, threads.</p>
</div>
<div id="section2" class="doctools_section"><h2><a name="section2">USER COMMANDS</a></h2>
<p>This section describes user-level commands. Those commands can be
used by script writers to control the execution of the tracing
framework.</p>
<dl class="doctools_definitions">
<dt><a name="1"><b class="cmd">ttrace::eval</b> <i class="arg">arg</i> <span class="opt">?arg ...?</span></a></dt>
<dd><p>This command concatenates given arguments and evaluates the resulting
Tcl command with trace framework enabled. If the command execution
was ok, it takes necessary steps to automatically propagate the
trace epoch change to all threads in the application.
For AOLserver, only newly created threads actually receive the
epoch change. For the Tcl threading extension, all threads created by
the extension are automatically updated. If the command execution
resulted in Tcl error, no state propagation takes place.</p>
<p>This is the most important user-level command of the package as
it wraps most of the commands described below. This greatly
simplifies things, because user need to learn just this (one)
command in order to effectively use the package. Other commands,
as desribed below, are included mostly for the sake of completeness.</p></dd>
<dt><a name="2"><b class="cmd">ttrace::enable</b></a></dt>
<dd><p>Activates all registered callbacks in the framework
and starts a new trace epoch. The trace epoch encapsulates all
changes done to the interpreter during the time traces are activated.</p></dd>
<dt><a name="3"><b class="cmd">ttrace::disable</b></a></dt>
<dd><p>Deactivates all registered callbacks in the framework
and closes the current trace epoch.</p></dd>
<dt><a name="4"><b class="cmd">ttrace::cleanup</b></a></dt>
<dd><p>Used to clean-up all on-demand loaded resources in the interpreter.
It effectively brings Tcl interpreter to its pristine state.</p></dd>
<dt><a name="5"><b class="cmd">ttrace::update</b> <span class="opt">?epoch?</span></a></dt>
<dd><p>Used to refresh the state of the interpreter to match the optional
trace <span class="opt">?epoch?</span>. If the optional <span class="opt">?epoch?</span> is not given, it takes
the most recent trace epoch.</p></dd>
<dt><a name="6"><b class="cmd">ttrace::getscript</b></a></dt>
<dd><p>Returns a synthetized Tcl script which may be sourced in any interpreter.
This script sets the stage for the Tcl <b class="cmd">unknown</b> command so it can
load traced resources from the in-memory database. Normally, this command
is automatically invoked by other higher-level commands like
<b class="cmd">ttrace::eval</b> and <b class="cmd">ttrace::update</b>.</p></dd>
</dl>
</div>
<div id="section3" class="doctools_section"><h2><a name="section3">CALLBACK COMMANDS</a></h2>
<p>A word upfront: the package already includes callbacks for tracing
following Tcl commands: <b class="cmd">proc</b>, <b class="cmd">namespace</b>, <b class="cmd">variable</b>,
<b class="cmd">load</b>, and <b class="cmd">rename</b>. Additionaly, a set of callbacks for
tracing resources (object, clasess) for the XOTcl v1.3.8+, an
OO-extension to Tcl, is also provided.
This gives a solid base for solving most of the real-life needs and
serves as an example for people wanting to customize the package
to cover their specific needs.</p>
<p>Below, you can find commands for registering callbacks in the
framework and for writing callback scripts. These callbacks are
invoked by the framework in order to gather interpreter state
changes, build in-memory database, perform custom-cleanups and
various other tasks.</p>
<dl class="doctools_definitions">
<dt><a name="7"><b class="cmd">ttrace::atenable</b> <i class="arg">cmd</i> <i class="arg">arglist</i> <i class="arg">body</i></a></dt>
<dd><p>Registers Tcl callback to be activated at <b class="cmd">ttrace::enable</b>.
Registered callbacks are activated on FIFO basis. The callback
definition includes the name of the callback, <i class="arg">cmd</i>, a list
of callback arguments, <i class="arg">arglist</i> and the <i class="arg">body</i> of the
callback. Effectively, this actually resembles the call interface
of the standard Tcl <b class="cmd">proc</b> command.</p></dd>
<dt><a name="8"><b class="cmd">ttrace::atdisable</b> <i class="arg">cmd</i> <i class="arg">arglist</i> <i class="arg">body</i></a></dt>
<dd><p>Registers Tcl callback to be activated at <b class="cmd">ttrace::disable</b>.
Registered callbacks are activated on FIFO basis. The callback
definition includes the name of the callback, <i class="arg">cmd</i>, a list
of callback arguments, <i class="arg">arglist</i> and the <i class="arg">body</i> of the
callback. Effectively, this actually resembles the call interface
of the standard Tcl <b class="cmd">proc</b> command.</p></dd>
<dt><a name="9"><b class="cmd">ttrace::addtrace</b> <i class="arg">cmd</i> <i class="arg">arglist</i> <i class="arg">body</i></a></dt>
<dd><p>Registers Tcl callback to be activated for tracing the Tcl
<b class="cmd">cmd</b> command. The callback definition includes the name of
the Tcl command to trace, <i class="arg">cmd</i>, a list of callback arguments,
<i class="arg">arglist</i> and the <i class="arg">body</i> of the callback. Effectively,
this actually resembles the call interface of the standard Tcl
<b class="cmd">proc</b> command.</p></dd>
<dt><a name="10"><b class="cmd">ttrace::addscript</b> <i class="arg">name</i> <i class="arg">body</i></a></dt>
<dd><p>Registers Tcl callback to be activated for building a Tcl
script to be passed to other interpreters. This script is
used to set the stage for the Tcl <b class="cmd">unknown</b> command.
Registered callbacks are activated on FIFO basis.
The callback definition includes the name of the callback,
<i class="arg">name</i> and the <i class="arg">body</i> of the callback.</p></dd>
<dt><a name="11"><b class="cmd">ttrace::addresolver</b> <i class="arg">cmd</i> <i class="arg">arglist</i> <i class="arg">body</i></a></dt>
<dd><p>Registers Tcl callback to be activated by the overloaded Tcl
<b class="cmd">unknown</b> command.
Registered callbacks are activated on FIFO basis.
This callback is used to resolve the resource and load the
resource in the current interpreter.</p></dd>
<dt><a name="12"><b class="cmd">ttrace::addcleanup</b> <i class="arg">body</i></a></dt>
<dd><p>Registers Tcl callback to be activated by the <b class="cmd">trace::cleanup</b>.
Registered callbacks are activated on FIFO basis.</p></dd>
<dt><a name="13"><b class="cmd">ttrace::addentry</b> <i class="arg">cmd</i> <i class="arg">var</i> <i class="arg">val</i></a></dt>
<dd><p>Adds one entry to the named in-memory database.</p></dd>
<dt><a name="14"><b class="cmd">ttrace::getentry</b> <i class="arg">cmd</i> <i class="arg">var</i></a></dt>
<dd><p>Returns the value of the entry from the named in-memory database.</p></dd>
<dt><a name="15"><b class="cmd">ttrace::getentries</b> <i class="arg">cmd</i> <span class="opt">?pattern?</span></a></dt>
<dd><p>Returns names of all entries from the named in-memory database.</p></dd>
<dt><a name="16"><b class="cmd">ttrace::delentry</b> <i class="arg">cmd</i></a></dt>
<dd><p>Deletes an entry from the named in-memory database.</p></dd>
<dt><a name="17"><b class="cmd">ttrace::preload</b> <i class="arg">cmd</i></a></dt>
<dd><p>Registers the Tcl command to be loaded in the interpreter.
Commands registered this way will always be the part of
the interpreter and not be on-demand loaded by the Tcl
<b class="cmd">unknown</b> command.</p></dd>
</dl>
</div>
<div id="section4" class="doctools_section"><h2><a name="section4">DISCUSSION</a></h2>
<p>Common introspective state-replication approaches use a custom Tcl
script to introspect the running interpreter and synthesize another
Tcl script to replicate this state in some other interpreter.
This package, on the contrary, uses Tcl command traces. Command
traces are registered on selected Tcl commands, like <b class="cmd">proc</b>,
<b class="cmd">namespace</b>, <b class="cmd">load</b> and other standard (and/or user-defined)
Tcl commands. When activated, those traces build an in-memory
database of created resources. This database is used as a resource
repository for the (overloaded) Tcl <b class="cmd">unknown</b> command which
creates the requested resource in the interpreter on demand.
This way, users can update just one interpreter (master) in one
thread and replicate that interpreter state (or part of it) to other
threads/interpreters in the process.</p>
<p>Immediate benefit of such approach is the much smaller memory footprint
of the application and much faster thread creation. By not actually
loading all necessary procedures (and other resources) in every thread
at the thread initialization time, but by deffering this to the time the
resource is actually referenced, significant improvements in both
memory consumption and thread initialization time can be achieved. Some
tests have shown that memory footprint of an multithreading Tcl application
went down more than three times and thread startup time was reduced for
about 50 times. Note that your mileage may vary.
Other benefits include much finer control about what (and when) gets
replicated from the master to other Tcl thread/interpreters.</p>
</div>
<div id="see-also" class="doctools_section"><h2><a name="see-also">See Also</a></h2>
<p>thread, tpool, tsv</p>
</div>
<div id="keywords" class="doctools_section"><h2><a name="keywords">Keywords</a></h2>
<p>command tracing, introspection</p>
</div>
</div></body></html>

236
pkgs/thread2.8.7/doc/man.macros Normal file
View File

@@ -0,0 +1,236 @@
'\" The definitions below are for supplemental macros used in Tcl/Tk
'\" manual entries.
'\"
'\" .AP type name in/out ?indent?
'\" Start paragraph describing an argument to a library procedure.
'\" type is type of argument (int, etc.), in/out is either "in", "out",
'\" or "in/out" to describe whether procedure reads or modifies arg,
'\" and indent is equivalent to second arg of .IP (shouldn't ever be
'\" needed; use .AS below instead)
'\"
'\" .AS ?type? ?name?
'\" Give maximum sizes of arguments for setting tab stops. Type and
'\" name are examples of largest possible arguments that will be passed
'\" to .AP later. If args are omitted, default tab stops are used.
'\"
'\" .BS
'\" Start box enclosure. From here until next .BE, everything will be
'\" enclosed in one large box.
'\"
'\" .BE
'\" End of box enclosure.
'\"
'\" .CS
'\" Begin code excerpt.
'\"
'\" .CE
'\" End code excerpt.
'\"
'\" .VS ?version? ?br?
'\" Begin vertical sidebar, for use in marking newly-changed parts
'\" of man pages. The first argument is ignored and used for recording
'\" the version when the .VS was added, so that the sidebars can be
'\" found and removed when they reach a certain age. If another argument
'\" is present, then a line break is forced before starting the sidebar.
'\"
'\" .VE
'\" End of vertical sidebar.
'\"
'\" .DS
'\" Begin an indented unfilled display.
'\"
'\" .DE
'\" End of indented unfilled display.
'\"
'\" .SO
'\" Start of list of standard options for a Tk widget. The
'\" options follow on successive lines, in four columns separated
'\" by tabs.
'\"
'\" .SE
'\" End of list of standard options for a Tk widget.
'\"
'\" .OP cmdName dbName dbClass
'\" Start of description of a specific option. cmdName gives the
'\" option's name as specified in the class command, dbName gives
'\" the option's name in the option database, and dbClass gives
'\" the option's class in the option database.
'\"
'\" .UL arg1 arg2
'\" Print arg1 underlined, then print arg2 normally.
'\"
'\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages.
.if t .wh -1.3i ^B
.nr ^l \n(.l
.ad b
'\" # Start an argument description
.de AP
.ie !"\\$4"" .TP \\$4
.el \{\
. ie !"\\$2"" .TP \\n()Cu
. el .TP 15
.\}
.ta \\n()Au \\n()Bu
.ie !"\\$3"" \{\
\&\\$1 \\fI\\$2\\fP (\\$3)
.\".b
.\}
.el \{\
.br
.ie !"\\$2"" \{\
\&\\$1 \\fI\\$2\\fP
.\}
.el \{\
\&\\fI\\$1\\fP
.\}
.\}
..
'\" # define tabbing values for .AP
.de AS
.nr )A 10n
.if !"\\$1"" .nr )A \\w'\\$1'u+3n
.nr )B \\n()Au+15n
.\"
.if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n
.nr )C \\n()Bu+\\w'(in/out)'u+2n
..
.AS Tcl_Interp Tcl_CreateInterp in/out
'\" # BS - start boxed text
'\" # ^y = starting y location
'\" # ^b = 1
.de BS
.br
.mk ^y
.nr ^b 1u
.if n .nf
.if n .ti 0
.if n \l'\\n(.lu\(ul'
.if n .fi
..
'\" # BE - end boxed text (draw box now)
.de BE
.nf
.ti 0
.mk ^t
.ie n \l'\\n(^lu\(ul'
.el \{\
.\" Draw four-sided box normally, but don't draw top of
.\" box if the box started on an earlier page.
.ie !\\n(^b-1 \{\
\h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
.\}
.el \}\
\h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
.\}
.\}
.fi
.br
.nr ^b 0
..
'\" # VS - start vertical sidebar
'\" # ^Y = starting y location
'\" # ^v = 1 (for troff; for nroff this doesn't matter)
.de VS
.if !"\\$2"" .br
.mk ^Y
.ie n 'mc \s12\(br\s0
.el .nr ^v 1u
..
'\" # VE - end of vertical sidebar
.de VE
.ie n 'mc
.el \{\
.ev 2
.nf
.ti 0
.mk ^t
\h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n'
.sp -1
.fi
.ev
.\}
.nr ^v 0
..
'\" # Special macro to handle page bottom: finish off current
'\" # box/sidebar if in box/sidebar mode, then invoked standard
'\" # page bottom macro.
.de ^B
.ev 2
'ti 0
'nf
.mk ^t
.if \\n(^b \{\
.\" Draw three-sided box if this is the box's first page,
.\" draw two sides but no top otherwise.
.ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
.el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
.\}
.if \\n(^v \{\
.nr ^x \\n(^tu+1v-\\n(^Yu
\kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c
.\}
.bp
'fi
.ev
.if \\n(^b \{\
.mk ^y
.nr ^b 2
.\}
.if \\n(^v \{\
.mk ^Y
.\}
..
'\" # DS - begin display
.de DS
.RS
.nf
.sp
..
'\" # DE - end display
.de DE
.fi
.RE
.sp
..
'\" # SO - start of list of standard options
.de SO
.SH "STANDARD OPTIONS"
.LP
.nf
.ta 5.5c 11c
.ft B
..
'\" # SE - end of list of standard options
.de SE
.fi
.ft R
.LP
See the \\fBoptions\\fR manual entry for details on the standard options.
..
'\" # OP - start of full description for a single option
.de OP
.LP
.nf
.ta 4c
Command-Line Name: \\fB\\$1\\fR
Database Name: \\fB\\$2\\fR
Database Class: \\fB\\$3\\fR
.fi
.IP
..
'\" # CS - begin code excerpt
.de CS
.RS
.nf
.ta .25i .5i .75i 1i
.if t .ft C
..
'\" # CE - end code excerpt
.de CE
.fi
.if t .ft R
.RE
..
.de UL
\\$1\l'|0\(ul'\\$2
..

863
pkgs/thread2.8.7/doc/man/thread.n Normal file
View File

@@ -0,0 +1,863 @@
'\"
'\" Generated from file '' by tcllib/doctools with format 'nroff'
'\"
.TH "thread" n 2\&.8 "Tcl Threading"
.\" The -*- nroff -*- definitions below are for supplemental macros used
.\" in Tcl/Tk manual entries.
.\"
.\" .AP type name in/out ?indent?
.\" Start paragraph describing an argument to a library procedure.
.\" type is type of argument (int, etc.), in/out is either "in", "out",
.\" or "in/out" to describe whether procedure reads or modifies arg,
.\" and indent is equivalent to second arg of .IP (shouldn't ever be
.\" needed; use .AS below instead)
.\"
.\" .AS ?type? ?name?
.\" Give maximum sizes of arguments for setting tab stops. Type and
.\" name are examples of largest possible arguments that will be passed
.\" to .AP later. If args are omitted, default tab stops are used.
.\"
.\" .BS
.\" Start box enclosure. From here until next .BE, everything will be
.\" enclosed in one large box.
.\"
.\" .BE
.\" End of box enclosure.
.\"
.\" .CS
.\" Begin code excerpt.
.\"
.\" .CE
.\" End code excerpt.
.\"
.\" .VS ?version? ?br?
.\" Begin vertical sidebar, for use in marking newly-changed parts
.\" of man pages. The first argument is ignored and used for recording
.\" the version when the .VS was added, so that the sidebars can be
.\" found and removed when they reach a certain age. If another argument
.\" is present, then a line break is forced before starting the sidebar.
.\"
.\" .VE
.\" End of vertical sidebar.
.\"
.\" .DS
.\" Begin an indented unfilled display.
.\"
.\" .DE
.\" End of indented unfilled display.
.\"
.\" .SO ?manpage?
.\" Start of list of standard options for a Tk widget. The manpage
.\" argument defines where to look up the standard options; if
.\" omitted, defaults to "options". The options follow on successive
.\" lines, in three columns separated by tabs.
.\"
.\" .SE
.\" End of list of standard options for a Tk widget.
.\"
.\" .OP cmdName dbName dbClass
.\" Start of description of a specific option. cmdName gives the
.\" option's name as specified in the class command, dbName gives
.\" the option's name in the option database, and dbClass gives
.\" the option's class in the option database.
.\"
.\" .UL arg1 arg2
.\" Print arg1 underlined, then print arg2 normally.
.\"
.\" .QW arg1 ?arg2?
.\" Print arg1 in quotes, then arg2 normally (for trailing punctuation).
.\"
.\" .PQ arg1 ?arg2?
.\" Print an open parenthesis, arg1 in quotes, then arg2 normally
.\" (for trailing punctuation) and then a closing parenthesis.
.\"
.\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages.
.if t .wh -1.3i ^B
.nr ^l \n(.l
.ad b
.\" # Start an argument description
.de AP
.ie !"\\$4"" .TP \\$4
.el \{\
. ie !"\\$2"" .TP \\n()Cu
. el .TP 15
.\}
.ta \\n()Au \\n()Bu
.ie !"\\$3"" \{\
\&\\$1 \\fI\\$2\\fP (\\$3)
.\".b
.\}
.el \{\
.br
.ie !"\\$2"" \{\
\&\\$1 \\fI\\$2\\fP
.\}
.el \{\
\&\\fI\\$1\\fP
.\}
.\}
..
.\" # define tabbing values for .AP
.de AS
.nr )A 10n
.if !"\\$1"" .nr )A \\w'\\$1'u+3n
.nr )B \\n()Au+15n
.\"
.if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n
.nr )C \\n()Bu+\\w'(in/out)'u+2n
..
.AS Tcl_Interp Tcl_CreateInterp in/out
.\" # BS - start boxed text
.\" # ^y = starting y location
.\" # ^b = 1
.de BS
.br
.mk ^y
.nr ^b 1u
.if n .nf
.if n .ti 0
.if n \l'\\n(.lu\(ul'
.if n .fi
..
.\" # BE - end boxed text (draw box now)
.de BE
.nf
.ti 0
.mk ^t
.ie n \l'\\n(^lu\(ul'
.el \{\
.\" Draw four-sided box normally, but don't draw top of
.\" box if the box started on an earlier page.
.ie !\\n(^b-1 \{\
\h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
.\}
.el \}\
\h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
.\}
.\}
.fi
.br
.nr ^b 0
..
.\" # VS - start vertical sidebar
.\" # ^Y = starting y location
.\" # ^v = 1 (for troff; for nroff this doesn't matter)
.de VS
.if !"\\$2"" .br
.mk ^Y
.ie n 'mc \s12\(br\s0
.el .nr ^v 1u
..
.\" # VE - end of vertical sidebar
.de VE
.ie n 'mc
.el \{\
.ev 2
.nf
.ti 0
.mk ^t
\h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n'
.sp -1
.fi
.ev
.\}
.nr ^v 0
..
.\" # Special macro to handle page bottom: finish off current
.\" # box/sidebar if in box/sidebar mode, then invoked standard
.\" # page bottom macro.
.de ^B
.ev 2
'ti 0
'nf
.mk ^t
.if \\n(^b \{\
.\" Draw three-sided box if this is the box's first page,
.\" draw two sides but no top otherwise.
.ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
.el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
.\}
.if \\n(^v \{\
.nr ^x \\n(^tu+1v-\\n(^Yu
\kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c
.\}
.bp
'fi
.ev
.if \\n(^b \{\
.mk ^y
.nr ^b 2
.\}
.if \\n(^v \{\
.mk ^Y
.\}
..
.\" # DS - begin display
.de DS
.RS
.nf
.sp
..
.\" # DE - end display
.de DE
.fi
.RE
.sp
..
.\" # SO - start of list of standard options
.de SO
'ie '\\$1'' .ds So \\fBoptions\\fR
'el .ds So \\fB\\$1\\fR
.SH "STANDARD OPTIONS"
.LP
.nf
.ta 5.5c 11c
.ft B
..
.\" # SE - end of list of standard options
.de SE
.fi
.ft R
.LP
See the \\*(So manual entry for details on the standard options.
..
.\" # OP - start of full description for a single option
.de OP
.LP
.nf
.ta 4c
Command-Line Name: \\fB\\$1\\fR
Database Name: \\fB\\$2\\fR
Database Class: \\fB\\$3\\fR
.fi
.IP
..
.\" # CS - begin code excerpt
.de CS
.RS
.nf
.ta .25i .5i .75i 1i
..
.\" # CE - end code excerpt
.de CE
.fi
.RE
..
.\" # UL - underline word
.de UL
\\$1\l'|0\(ul'\\$2
..
.\" # QW - apply quotation marks to word
.de QW
.ie '\\*(lq'"' ``\\$1''\\$2
.\"" fix emacs highlighting
.el \\*(lq\\$1\\*(rq\\$2
..
.\" # PQ - apply parens and quotation marks to word
.de PQ
.ie '\\*(lq'"' (``\\$1''\\$2)\\$3
.\"" fix emacs highlighting
.el (\\*(lq\\$1\\*(rq\\$2)\\$3
..
.\" # QR - quoted range
.de QR
.ie '\\*(lq'"' ``\\$1''\\-``\\$2''\\$3
.\"" fix emacs highlighting
.el \\*(lq\\$1\\*(rq\\-\\*(lq\\$2\\*(rq\\$3
..
.\" # MT - "empty" string
.de MT
.QW ""
..
.BS
.SH NAME
thread \- Extension for script access to Tcl threading
.SH SYNOPSIS
package require \fBTcl 8\&.4\fR
.sp
package require \fBThread ?2\&.8?\fR
.sp
\fBthread::create\fR ?-joinable? ?-preserved? ?script?
.sp
\fBthread::preserve\fR ?id?
.sp
\fBthread::release\fR ?-wait? ?id?
.sp
\fBthread::id\fR
.sp
\fBthread::errorproc\fR ?procname?
.sp
\fBthread::cancel\fR ?-unwind? \fIid\fR ?result?
.sp
\fBthread::unwind\fR
.sp
\fBthread::exit\fR ?status?
.sp
\fBthread::names\fR
.sp
\fBthread::exists\fR \fIid\fR
.sp
\fBthread::send\fR ?-async? ?-head? \fIid\fR \fIscript\fR ?varname?
.sp
\fBthread::broadcast\fR \fIscript\fR
.sp
\fBthread::wait\fR
.sp
\fBthread::eval\fR ?-lock mutex? \fIarg\fR ?arg \&.\&.\&.?
.sp
\fBthread::join\fR \fIid\fR
.sp
\fBthread::configure\fR \fIid\fR ?option? ?value? ?\&.\&.\&.?
.sp
\fBthread::transfer\fR \fIid\fR \fIchannel\fR
.sp
\fBthread::detach\fR \fIchannel\fR
.sp
\fBthread::attach\fR \fIchannel\fR
.sp
\fBthread::mutex\fR
.sp
\fBthread::mutex\fR \fBcreate\fR ?-recursive?
.sp
\fBthread::mutex\fR \fBdestroy\fR \fImutex\fR
.sp
\fBthread::mutex\fR \fBlock\fR \fImutex\fR
.sp
\fBthread::mutex\fR \fBunlock\fR \fImutex\fR
.sp
\fBthread::rwmutex\fR
.sp
\fBthread::rwmutex\fR \fBcreate\fR
.sp
\fBthread::rwmutex\fR \fBdestroy\fR \fImutex\fR
.sp
\fBthread::rwmutex\fR \fBrlock\fR \fImutex\fR
.sp
\fBthread::rwmutex\fR \fBwlock\fR \fImutex\fR
.sp
\fBthread::rwmutex\fR \fBunlock\fR \fImutex\fR
.sp
\fBthread::cond\fR
.sp
\fBthread::cond\fR \fBcreate\fR
.sp
\fBthread::cond\fR \fBdestroy\fR \fIcond\fR
.sp
\fBthread::cond\fR \fBnotify\fR \fIcond\fR
.sp
\fBthread::cond\fR \fBwait\fR \fIcond\fR \fImutex\fR ?ms?
.sp
.BE
.SH DESCRIPTION
The \fBthread\fR extension creates threads that contain Tcl
interpreters, and it lets you send scripts to those threads for
evaluation\&.
Additionally, it provides script-level access to basic thread
synchronization primitives, like mutexes and condition variables\&.
.SH COMMANDS
This section describes commands for creating and destroying threads
and sending scripts to threads for evaluation\&.
.TP
\fBthread::create\fR ?-joinable? ?-preserved? ?script?
This command creates a thread that contains a Tcl interpreter\&.
The Tcl interpreter either evaluates the optional \fBscript\fR, if
specified, or it waits in the event loop for scripts that arrive via
the \fBthread::send\fR command\&. Both of them would take place simultaneously
with the return of command \fBthread::create\fR to the caller thread\&.
Neither the caller is waiting for the finishing of optional \fBscript\fR,
nor the result, if any, of the \fBscript\fR is returned to the caller\&.
The result of \fBthread::create\fR is the ID of the thread\&. This is
the opaque handle which identifies the newly created thread for
all other package commands\&. The handle of the thread goes out of scope
automatically when thread is marked for exit
(see the \fBthread::release\fR command below)\&.
.sp
If the optional \fBscript\fR argument contains the \fBthread::wait\fR
command the thread will enter into the event loop\&. If such command is not
found in the \fBscript\fR the thread will run the \fBscript\fR to
the end and exit\&. In that case, the handle may be safely ignored since it
refers to a thread which does not exists any more at the time when the
command returns\&.
.sp
Using flag \fB-joinable\fR it is possible to create a joinable
thread, i\&.e\&. one upon whose exit can be waited upon by using
\fBthread::join\fR command\&.
Note that failure to join a thread created with \fB-joinable\fR flag
results in resource and memory leaks\&.
.sp
Threads created by the \fBthread::create\fR cannot be destroyed
forcefully\&. Consequently, there is no corresponding thread destroy
command\&. A thread may only be released using the \fBthread::release\fR
and if its internal reference count drops to zero, the thread is
marked for exit\&. This kicks the thread out of the event loop
servicing and the thread continues to execute commands passed in
the \fBscript\fR argument, following the \fBthread::wait\fR
command\&. If this was the last command in the script, as usually the
case, the thread will exit\&.
.sp
It is possible to create a situation in which it may be impossible
to terminate the thread, for example by putting some endless loop
after the \fBthread::wait\fR or entering the event loop again by
doing an vwait-type of command\&. In such cases, the thread may never
exit\&. This is considered to be a bad practice and should be avoided
if possible\&. This is best illustrated by the example below:
.CS
# You should never do \&.\&.\&.
set tid [thread::create {
package require Http
thread::wait
vwait forever ; # <-- this!
}]
.CE
.IP
The thread created in the above example will never be able to exit\&.
After it has been released with the last matching \fBthread::release\fR
call, the thread will jump out of the \fBthread::wait\fR and continue
to execute commands following\&. It will enter \fBvwait\fR command and
wait endlessly for events\&. There is no way one can terminate such thread,
so you wouldn't want to do this!
.sp
Each newly created has its internal reference counter set to 0 (zero),
i\&.e\&. it is unreserved\&. This counter gets incremented by a call to
\fBthread::preserve\fR and decremented by a call to \fBthread::release\fR
command\&. These two commands implement simple but effective thread
reservation system and offer predictable and controllable thread
termination capabilities\&. It is however possible to create initially
preserved threads by using flag \fB-preserved\fR of the
\fBthread::create\fR command\&. Threads created with this flag have the
initial value of the reference counter of 1 (one), and are thus
initially marked reserved\&.
.TP
\fBthread::preserve\fR ?id?
This command increments the thread reference counter\&. Each call
to this command increments the reference counter by one (1)\&.
Command returns the value of the reference counter after the increment\&.
If called with the optional thread \fBid\fR, the command preserves
the given thread\&. Otherwise the current thread is preserved\&.
.sp
With reference counting, one can implement controlled access to a
shared Tcl thread\&. By incrementing the reference counter, the
caller signalizes that he/she wishes to use the thread for a longer
period of time\&. By decrementing the counter, caller signalizes that
he/she has finished using the thread\&.
.TP
\fBthread::release\fR ?-wait? ?id?
This command decrements the thread reference counter\&. Each call to
this command decrements the reference counter by one (1)\&.
If called with the optional thread \fBid\fR, the command releases
the given thread\&. Otherwise, the current thread is released\&.
Command returns the value of the reference counter after the decrement\&.
When the reference counter reaches zero (0), the target thread is
marked for termination\&. You should not reference the thread after the
\fBthread::release\fR command returns zero or negative integer\&.
The handle of the thread goes out of scope and should not be used any
more\&. Any following reference to the same thread handle will result
in Tcl error\&.
.sp
Optional flag \fB-wait\fR instructs the caller thread to wait for
the target thread to exit, if the effect of the command would result
in termination of the target thread, i\&.e\&. if the return result would
be zero (0)\&. Without the flag, the caller thread does not wait for
the target thread to exit\&. Care must be taken when using the
\fB-wait\fR, since this may block the caller thread indefinitely\&.
This option has been implemented for some special uses of the extension
and is deprecated for regular use\&. Regular users should create joinable
threads by using the \fB-joinable\fR option of the \fBthread::create\fR
command and the \fBthread::join\fR to wait for thread to exit\&.
.TP
\fBthread::id\fR
This command returns the ID of the current thread\&.
.TP
\fBthread::errorproc\fR ?procname?
This command sets a handler for errors that occur in scripts sent
asynchronously, using the \fB-async\fR flag of the
\fBthread::send\fR command, to other threads\&. If no handler
is specified, the current handler is returned\&. The empty string
resets the handler to default (unspecified) value\&.
An uncaught error in a thread causes an error message to be sent
to the standard error channel\&. This default reporting scheme can
be changed by registering a procedure which is called to report
the error\&. The \fIprocname\fR is called in the interpreter that
invoked the \fBthread::errorproc\fR command\&. The \fIprocname\fR
is called like this:
.CS
myerrorproc thread_id errorInfo
.CE
.TP
\fBthread::cancel\fR ?-unwind? \fIid\fR ?result?
This command requires Tcl version 8\&.6 or higher\&.
.sp
Cancels the script being evaluated in the thread given by the \fIid\fR
parameter\&. Without the \fB-unwind\fR switch the evaluation stack for
the interpreter is unwound until an enclosing catch command is found or
there are no further invocations of the interpreter left on the call
stack\&. With the \fB-unwind\fR switch the evaluation stack for the
interpreter is unwound without regard to any intervening catch command
until there are no further invocations of the interpreter left on the
call stack\&. If \fIresult\fR is present, it will be used as the error
message string; otherwise, a default error message string will be used\&.
.TP
\fBthread::unwind\fR
Use of this command is deprecated in favour of more advanced thread
reservation system implemented with \fBthread::preserve\fR and
\fBthread::release\fR commands\&. Support for \fBthread::unwind\fR
command will disappear in some future major release of the extension\&.
.sp
This command stops a prior \fBthread::wait\fR command\&. Execution of
the script passed to newly created thread will continue from the
\fBthread::wait\fR command\&. If \fBthread::wait\fR was the last command
in the script, the thread will exit\&. The command returns empty result
but may trigger Tcl error with the message "target thread died" in some
situations\&.
.TP
\fBthread::exit\fR ?status?
Use of this command is deprecated in favour of more advanced thread
reservation system implemented with \fBthread::preserve\fR and
\fBthread::release\fR commands\&. Support for \fBthread::exit\fR
command will disappear in some future major release of the extension\&.
.sp
This command forces a thread stuck in the \fBthread::wait\fR command to
unconditionally exit\&. The thread's exit status defaults to 666 and can be
specified using the optional \fIstatus\fR argument\&. The execution of
\fBthread::exit\fR command is guaranteed to leave the program memory in the
inconsistent state, produce memory leaks and otherwise affect other subsystem(s)
of the Tcl application in an unpredictable manner\&. The command returns empty
result but may trigger Tcl error with the message "target thread died" in some
situations\&.
.TP
\fBthread::names\fR
This command returns a list of thread IDs\&. These are only for
threads that have been created via \fBthread::create\fR command\&.
If your application creates other threads at the C level, they
are not reported by this command\&.
.TP
\fBthread::exists\fR \fIid\fR
Returns true (1) if thread given by the \fIid\fR parameter exists,
false (0) otherwise\&. This applies only for threads that have
been created via \fBthread::create\fR command\&.
.TP
\fBthread::send\fR ?-async? ?-head? \fIid\fR \fIscript\fR ?varname?
This command passes a \fIscript\fR to another thread and, optionally,
waits for the result\&. If the \fB-async\fR flag is specified, the
command does not wait for the result and it returns empty string\&.
The target thread must enter it's event loop in order to receive
scripts sent via this command\&. This is done by default for threads
created without a startup script\&. Threads can enter the event loop
explicitly by calling \fBthread::wait\fR or any other relevant Tcl/Tk
command, like \fBupdate\fR, \fBvwait\fR, etc\&.
.sp
Optional \fBvarname\fR specifies name of the variable to store
the result of the \fIscript\fR\&. Without the \fB-async\fR flag,
the command returns the evaluation code, similarly to the standard
Tcl \fBcatch\fR command\&. If, however, the \fB-async\fR flag is
specified, the command returns immediately and caller can later
\fBvwait\fR on ?varname? to get the result of the passed \fIscript\fR
.CS
set t1 [thread::create]
set t2 [thread::create]
thread::send -async $t1 "set a 1" result
thread::send -async $t2 "set b 2" result
for {set i 0} {$i < 2} {incr i} {
vwait result
}
.CE
.IP
In the above example, two threads were fed work and both of them were
instructed to signalize the same variable "result" in the calling thread\&.
The caller entered the event loop twice to get both results\&. Note,
however, that the order of the received results may vary, depending on
the current system load, type of work done, etc, etc\&.
.sp
Many threads can simultaneously send scripts to the target thread for
execution\&. All of them are entered into the event queue of the target
thread and executed on the FIFO basis, intermingled with optional other
events pending in the event queue of the target thread\&.
Using the optional ?-head? switch, scripts posted to the thread's
event queue can be placed on the head, instead on the tail of the queue,
thus being executed in the LIFO fashion\&.
.TP
\fBthread::broadcast\fR \fIscript\fR
This command passes a \fIscript\fR to all threads created by the
package for execution\&. It does not wait for response from any of
the threads\&.
.TP
\fBthread::wait\fR
This enters the event loop so a thread can receive messages from
the \fBthread::send\fR command\&. This command should only be used
within the script passed to the \fBthread::create\fR\&. It should
be the very last command in the script\&. If this is not the case,
the exiting thread will continue executing the script lines past
the \fBthread::wait\fR which is usually not what you want and/or
expect\&.
.CS
set t1 [thread::create {
#
# Do some initialization work here
#
thread::wait ; # Enter the event loop
}]
.CE
.TP
\fBthread::eval\fR ?-lock mutex? \fIarg\fR ?arg \&.\&.\&.?
This command concatenates passed arguments and evaluates the
resulting script under the mutex protection\&. If no mutex is
specified by using the ?-lock mutex? optional argument,
the internal static mutex is used\&.
.TP
\fBthread::join\fR \fIid\fR
This command waits for the thread with ID \fIid\fR to exit and
then returns it's exit code\&. Errors will be returned for threads
which are not joinable or already waited upon by another thread\&.
Upon the join the handle of the thread has gone out of scope and
should not be used any more\&.
.TP
\fBthread::configure\fR \fIid\fR ?option? ?value? ?\&.\&.\&.?
This command configures various low-level aspects of the thread with
ID \fIid\fR in the similar way as the standard Tcl command
\fBfconfigure\fR configures some Tcl channel options\&. Options currently
supported are: \fB-eventmark\fR and \fB-unwindonerror\fR\&.
.sp
When \fB-eventmark\fR is provided with a value greater than 0 (zero), that
value is the maximum number of asynchronously posted scripts that may be
pending for the thread\&. \fBthread::send -async\fR blocks until the number of
pending scripts in the event loop drops below the \fB-eventmark\fR value\&.
.sp
When \fB-unwindonerror\fR is provided with a value of true, an error result
in a script causes the thread to unwind, making it unavailable to evaluate
additional scripts\&.
.TP
\fBthread::transfer\fR \fIid\fR \fIchannel\fR
This moves the specified \fIchannel\fR from the current thread
and interpreter to the main interpreter of the thread with the
given \fIid\fR\&. After the move the current interpreter has no
access to the channel any more, but the main interpreter of the
target thread will be able to use it from now on\&.
The command waits until the other thread has incorporated the
channel\&. Because of this it is possible to deadlock the
participating threads by commanding the other through a
synchronous \fBthread::send\fR to transfer a channel to us\&.
This easily extends into longer loops of threads waiting for
each other\&. Other restrictions: the channel in question must
not be shared among multiple interpreters running in the
sending thread\&. This automatically excludes the special channels
for standard input, output and error\&.
.sp
Due to the internal Tcl core implementation and the restriction on
transferring shared channels, one has to take extra measures when
transferring socket channels created by accepting the connection
out of the \fBsocket\fR commands callback procedures:
.CS
socket -server _Accept 2200
proc _Accept {s ipaddr port} {
after idle [list Accept $s $ipaddr $port]
}
proc Accept {s ipaddr port} {
set tid [thread::create]
thread::transfer $tid $s
}
.CE
.TP
\fBthread::detach\fR \fIchannel\fR
This detaches the specified \fIchannel\fR from the current thread and
interpreter\&. After that, the current interpreter has no access to the
channel any more\&. The channel is in the parked state until some other
(or the same) thread attaches the channel again with \fBthread::attach\fR\&.
Restrictions: same as for transferring shared channels with the
\fBthread::transfer\fR command\&.
.TP
\fBthread::attach\fR \fIchannel\fR
This attaches the previously detached \fIchannel\fR in the
current thread/interpreter\&. For already existing channels,
the command does nothing, i\&.e\&. it is not an error to attach the
same channel more than once\&. The first operation will actually
perform the operation, while all subsequent operation will just
do nothing\&. Command throws error if the \fIchannel\fR cannot be
found in the list of detached channels and/or in the current
interpreter\&.
.TP
\fBthread::mutex\fR
Mutexes are most common thread synchronization primitives\&.
They are used to synchronize access from two or more threads to one or
more shared resources\&. This command provides script-level access to
exclusive and/or recursive mutexes\&. Exclusive mutexes can be locked
only once by one thread, while recursive mutexes can be locked many
times by the same thread\&. For recursive mutexes, number of lock and
unlock operations must match, otherwise, the mutex will never be
released, which would lead to various deadlock situations\&.
.sp
Care has to be taken when using mutexes in an multithreading program\&.
Improper use of mutexes may lead to various deadlock situations,
especially when using exclusive mutexes\&.
.sp
The \fBthread::mutex\fR command supports following subcommands and options:
.RS
.TP
\fBthread::mutex\fR \fBcreate\fR ?-recursive?
Creates the mutex and returns it's opaque handle\&. This handle
should be used for any future reference to the newly created mutex\&.
If no optional ?-recursive? argument was specified, the command
creates the exclusive mutex\&. With the ?-recursive? argument,
the command creates a recursive mutex\&.
.TP
\fBthread::mutex\fR \fBdestroy\fR \fImutex\fR
Destroys the \fImutex\fR\&. Mutex should be in unlocked state before
the destroy attempt\&. If the mutex is locked, the command will throw
Tcl error\&.
.TP
\fBthread::mutex\fR \fBlock\fR \fImutex\fR
Locks the \fImutex\fR\&. Locking the exclusive mutex may throw Tcl
error if on attempt to lock the same mutex twice from the same
thread\&. If your program logic forces you to lock the same mutex
twice or more from the same thread (this may happen in recursive
procedure invocations) you should consider using the recursive mutexes\&.
.TP
\fBthread::mutex\fR \fBunlock\fR \fImutex\fR
Unlocks the \fImutex\fR so some other thread may lock it again\&.
Attempt to unlock the already unlocked mutex will throw Tcl error\&.
.RE
.sp
.TP
\fBthread::rwmutex\fR
This command creates many-readers/single-writer mutexes\&. Reader/writer
mutexes allow you to serialize access to a shared resource more optimally\&.
In situations where a shared resource gets mostly read and seldom modified,
you might gain some performance by using reader/writer mutexes instead of
exclusive or recursive mutexes\&.
.sp
For reading the resource, thread should obtain a read lock on the resource\&.
Read lock is non-exclusive, meaning that more than one thread can
obtain a read lock to the same resource, without waiting on other readers\&.
For changing the resource, however, a thread must obtain a exclusive
write lock\&. This lock effectively blocks all threads from gaining the
read-lock while the resource is been modified by the writer thread\&.
Only after the write lock has been released, the resource may be read-locked
again\&.
.sp
The \fBthread::rwmutex\fR command supports following subcommands and options:
.RS
.TP
\fBthread::rwmutex\fR \fBcreate\fR
Creates the reader/writer mutex and returns it's opaque handle\&.
This handle should be used for any future reference to the newly
created mutex\&.
.TP
\fBthread::rwmutex\fR \fBdestroy\fR \fImutex\fR
Destroys the reader/writer \fImutex\fR\&. If the mutex is already locked,
attempt to destroy it will throw Tcl error\&.
.TP
\fBthread::rwmutex\fR \fBrlock\fR \fImutex\fR
Locks the \fImutex\fR for reading\&. More than one thread may read-lock
the same \fImutex\fR at the same time\&.
.TP
\fBthread::rwmutex\fR \fBwlock\fR \fImutex\fR
Locks the \fImutex\fR for writing\&. Only one thread may write-lock
the same \fImutex\fR at the same time\&. Attempt to write-lock same
\fImutex\fR twice from the same thread will throw Tcl error\&.
.TP
\fBthread::rwmutex\fR \fBunlock\fR \fImutex\fR
Unlocks the \fImutex\fR so some other thread may lock it again\&.
Attempt to unlock already unlocked \fImutex\fR will throw Tcl error\&.
.RE
.sp
.TP
\fBthread::cond\fR
This command provides script-level access to condition variables\&.
A condition variable creates a safe environment for the program
to test some condition, sleep on it when false and be awakened
when it might have become true\&. A condition variable is always
used in the conjunction with an exclusive mutex\&. If you attempt
to use other type of mutex in conjunction with the condition
variable, a Tcl error will be thrown\&.
.sp
The command supports following subcommands and options:
.RS
.TP
\fBthread::cond\fR \fBcreate\fR
Creates the condition variable and returns it's opaque handle\&.
This handle should be used for any future reference to newly
created condition variable\&.
.TP
\fBthread::cond\fR \fBdestroy\fR \fIcond\fR
Destroys condition variable \fIcond\fR\&. Extreme care has to be taken
that nobody is using (i\&.e\&. waiting on) the condition variable,
otherwise unexpected errors may happen\&.
.TP
\fBthread::cond\fR \fBnotify\fR \fIcond\fR
Wakes up all threads waiting on the condition variable \fIcond\fR\&.
.TP
\fBthread::cond\fR \fBwait\fR \fIcond\fR \fImutex\fR ?ms?
This command is used to suspend program execution until the condition
variable \fIcond\fR has been signalled or the optional timer has expired\&.
The exclusive \fImutex\fR must be locked by the calling thread on entrance
to this command\&. If the mutex is not locked, Tcl error is thrown\&.
While waiting on the \fIcond\fR, the command releases \fImutex\fR\&.
Before returning to the calling thread, the command re-acquires the
\fImutex\fR again\&. Unlocking the \fImutex\fR and waiting on the
condition variable \fIcond\fR is done atomically\&.
.sp
The \fBms\fR command option, if given, must be an integer specifying
time interval in milliseconds the command waits to be signalled\&.
Otherwise the command waits on condition notify forever\&.
.sp
In multithreading programs, there are many situations where a thread has
to wait for some event to happen until it is allowed to proceed\&.
This is usually accomplished by repeatedly testing a condition under the
mutex protection and waiting on the condition variable until the condition
evaluates to true:
.CS
set mutex [thread::mutex create]
set cond [thread::cond create]
thread::mutex lock $mutex
while {<some_condition_is_true>} {
thread::cond wait $cond $mutex
}
# Do some work under mutex protection
thread::mutex unlock $mutex
.CE
.IP
Repeated testing of the condition is needed since the condition variable
may get signalled without the condition being actually changed (spurious
thread wake-ups, for example)\&.
.RE
.PP
.SH DISCUSSION
The fundamental threading model in Tcl is that there can be one or
more Tcl interpreters per thread, but each Tcl interpreter should
only be used by a single thread which created it\&.
A "shared memory" abstraction is awkward to provide in Tcl because
Tcl makes assumptions about variable and data ownership\&. Therefore
this extension supports a simple form of threading where the main
thread can manage several background, or "worker" threads\&.
For example, an event-driven server can pass requests to worker
threads, and then await responses from worker threads or new client
requests\&. Everything goes through the common Tcl event loop, so
message passing between threads works naturally with event-driven I/O,
\fBvwait\fR on variables, and so forth\&. For the transfer of bulk
information it is possible to move channels between the threads\&.
.PP
For advanced multithreading scripts, script-level access to two
basic synchronization primitives, mutex and condition variables,
is also supported\&.
.SH "SEE ALSO"
\fIhttp://www\&.tcl\&.tk/doc/howto/thread_model\&.html\fR, tpool, tsv, ttrace
.SH KEYWORDS
events, message passing, mutex, synchronization, thread

496
pkgs/thread2.8.7/doc/man/tpool.n Normal file
View File

@@ -0,0 +1,496 @@
'\"
'\" Generated from file '' by tcllib/doctools with format 'nroff'
'\"
.TH "tpool" n 2\&.8 "Tcl Threading"
.\" The -*- nroff -*- definitions below are for supplemental macros used
.\" in Tcl/Tk manual entries.
.\"
.\" .AP type name in/out ?indent?
.\" Start paragraph describing an argument to a library procedure.
.\" type is type of argument (int, etc.), in/out is either "in", "out",
.\" or "in/out" to describe whether procedure reads or modifies arg,
.\" and indent is equivalent to second arg of .IP (shouldn't ever be
.\" needed; use .AS below instead)
.\"
.\" .AS ?type? ?name?
.\" Give maximum sizes of arguments for setting tab stops. Type and
.\" name are examples of largest possible arguments that will be passed
.\" to .AP later. If args are omitted, default tab stops are used.
.\"
.\" .BS
.\" Start box enclosure. From here until next .BE, everything will be
.\" enclosed in one large box.
.\"
.\" .BE
.\" End of box enclosure.
.\"
.\" .CS
.\" Begin code excerpt.
.\"
.\" .CE
.\" End code excerpt.
.\"
.\" .VS ?version? ?br?
.\" Begin vertical sidebar, for use in marking newly-changed parts
.\" of man pages. The first argument is ignored and used for recording
.\" the version when the .VS was added, so that the sidebars can be
.\" found and removed when they reach a certain age. If another argument
.\" is present, then a line break is forced before starting the sidebar.
.\"
.\" .VE
.\" End of vertical sidebar.
.\"
.\" .DS
.\" Begin an indented unfilled display.
.\"
.\" .DE
.\" End of indented unfilled display.
.\"
.\" .SO ?manpage?
.\" Start of list of standard options for a Tk widget. The manpage
.\" argument defines where to look up the standard options; if
.\" omitted, defaults to "options". The options follow on successive
.\" lines, in three columns separated by tabs.
.\"
.\" .SE
.\" End of list of standard options for a Tk widget.
.\"
.\" .OP cmdName dbName dbClass
.\" Start of description of a specific option. cmdName gives the
.\" option's name as specified in the class command, dbName gives
.\" the option's name in the option database, and dbClass gives
.\" the option's class in the option database.
.\"
.\" .UL arg1 arg2
.\" Print arg1 underlined, then print arg2 normally.
.\"
.\" .QW arg1 ?arg2?
.\" Print arg1 in quotes, then arg2 normally (for trailing punctuation).
.\"
.\" .PQ arg1 ?arg2?
.\" Print an open parenthesis, arg1 in quotes, then arg2 normally
.\" (for trailing punctuation) and then a closing parenthesis.
.\"
.\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages.
.if t .wh -1.3i ^B
.nr ^l \n(.l
.ad b
.\" # Start an argument description
.de AP
.ie !"\\$4"" .TP \\$4
.el \{\
. ie !"\\$2"" .TP \\n()Cu
. el .TP 15
.\}
.ta \\n()Au \\n()Bu
.ie !"\\$3"" \{\
\&\\$1 \\fI\\$2\\fP (\\$3)
.\".b
.\}
.el \{\
.br
.ie !"\\$2"" \{\
\&\\$1 \\fI\\$2\\fP
.\}
.el \{\
\&\\fI\\$1\\fP
.\}
.\}
..
.\" # define tabbing values for .AP
.de AS
.nr )A 10n
.if !"\\$1"" .nr )A \\w'\\$1'u+3n
.nr )B \\n()Au+15n
.\"
.if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n
.nr )C \\n()Bu+\\w'(in/out)'u+2n
..
.AS Tcl_Interp Tcl_CreateInterp in/out
.\" # BS - start boxed text
.\" # ^y = starting y location
.\" # ^b = 1
.de BS
.br
.mk ^y
.nr ^b 1u
.if n .nf
.if n .ti 0
.if n \l'\\n(.lu\(ul'
.if n .fi
..
.\" # BE - end boxed text (draw box now)
.de BE
.nf
.ti 0
.mk ^t
.ie n \l'\\n(^lu\(ul'
.el \{\
.\" Draw four-sided box normally, but don't draw top of
.\" box if the box started on an earlier page.
.ie !\\n(^b-1 \{\
\h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
.\}
.el \}\
\h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
.\}
.\}
.fi
.br
.nr ^b 0
..
.\" # VS - start vertical sidebar
.\" # ^Y = starting y location
.\" # ^v = 1 (for troff; for nroff this doesn't matter)
.de VS
.if !"\\$2"" .br
.mk ^Y
.ie n 'mc \s12\(br\s0
.el .nr ^v 1u
..
.\" # VE - end of vertical sidebar
.de VE
.ie n 'mc
.el \{\
.ev 2
.nf
.ti 0
.mk ^t
\h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n'
.sp -1
.fi
.ev
.\}
.nr ^v 0
..
.\" # Special macro to handle page bottom: finish off current
.\" # box/sidebar if in box/sidebar mode, then invoked standard
.\" # page bottom macro.
.de ^B
.ev 2
'ti 0
'nf
.mk ^t
.if \\n(^b \{\
.\" Draw three-sided box if this is the box's first page,
.\" draw two sides but no top otherwise.
.ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
.el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
.\}
.if \\n(^v \{\
.nr ^x \\n(^tu+1v-\\n(^Yu
\kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c
.\}
.bp
'fi
.ev
.if \\n(^b \{\
.mk ^y
.nr ^b 2
.\}
.if \\n(^v \{\
.mk ^Y
.\}
..
.\" # DS - begin display
.de DS
.RS
.nf
.sp
..
.\" # DE - end display
.de DE
.fi
.RE
.sp
..
.\" # SO - start of list of standard options
.de SO
'ie '\\$1'' .ds So \\fBoptions\\fR
'el .ds So \\fB\\$1\\fR
.SH "STANDARD OPTIONS"
.LP
.nf
.ta 5.5c 11c
.ft B
..
.\" # SE - end of list of standard options
.de SE
.fi
.ft R
.LP
See the \\*(So manual entry for details on the standard options.
..
.\" # OP - start of full description for a single option
.de OP
.LP
.nf
.ta 4c
Command-Line Name: \\fB\\$1\\fR
Database Name: \\fB\\$2\\fR
Database Class: \\fB\\$3\\fR
.fi
.IP
..
.\" # CS - begin code excerpt
.de CS
.RS
.nf
.ta .25i .5i .75i 1i
..
.\" # CE - end code excerpt
.de CE
.fi
.RE
..
.\" # UL - underline word
.de UL
\\$1\l'|0\(ul'\\$2
..
.\" # QW - apply quotation marks to word
.de QW
.ie '\\*(lq'"' ``\\$1''\\$2
.\"" fix emacs highlighting
.el \\*(lq\\$1\\*(rq\\$2
..
.\" # PQ - apply parens and quotation marks to word
.de PQ
.ie '\\*(lq'"' (``\\$1''\\$2)\\$3
.\"" fix emacs highlighting
.el (\\*(lq\\$1\\*(rq\\$2)\\$3
..
.\" # QR - quoted range
.de QR
.ie '\\*(lq'"' ``\\$1''\\-``\\$2''\\$3
.\"" fix emacs highlighting
.el \\*(lq\\$1\\*(rq\\-\\*(lq\\$2\\*(rq\\$3
..
.\" # MT - "empty" string
.de MT
.QW ""
..
.BS
.SH NAME
tpool \- Part of the Tcl threading extension implementing pools of worker threads\&.
.SH SYNOPSIS
package require \fBTcl 8\&.4\fR
.sp
package require \fBThread ?2\&.8?\fR
.sp
\fBtpool::create\fR ?options?
.sp
\fBtpool::names\fR
.sp
\fBtpool::post\fR ?-detached? ?-nowait? \fItpool\fR \fIscript\fR
.sp
\fBtpool::wait\fR \fItpool\fR \fIjoblist\fR ?varname?
.sp
\fBtpool::cancel\fR \fItpool\fR \fIjoblist\fR ?varname?
.sp
\fBtpool::get\fR \fItpool\fR \fIjob\fR
.sp
\fBtpool::preserve\fR \fItpool\fR
.sp
\fBtpool::release\fR \fItpool\fR
.sp
\fBtpool::suspend\fR \fItpool\fR
.sp
\fBtpool::resume\fR \fItpool\fR
.sp
.BE
.SH DESCRIPTION
This package creates and manages pools of worker threads\&. It allows you
to post jobs to worker threads and wait for their completion\&. The
threadpool implementation is Tcl event-loop aware\&. That means that any
time a caller is forced to wait for an event (job being completed or
a worker thread becoming idle or initialized), the implementation will
enter the event loop and allow for servicing of other pending file or
timer (or any other supported) events\&.
.SH COMMANDS
.TP
\fBtpool::create\fR ?options?
This command creates new threadpool\&. It accepts several options as
key-value pairs\&. Options are used to tune some threadpool parameters\&.
The command returns the ID of the newly created threadpool\&.
.sp
Following options are supported:
.RS
.TP
\fB-minworkers\fR \fInumber\fR
Minimum number of worker threads needed for this threadpool instance\&.
During threadpool creation, the implementation will create somany
worker threads upfront and will keep at least number of them alive
during the lifetime of the threadpool instance\&.
Default value of this parameter is 0 (zero)\&. which means that a newly
threadpool will have no worker threads initialy\&. All worker threads
will be started on demand by callers running \fBtpool::post\fR command
and posting jobs to the job queue\&.
.TP
\fB-maxworkers\fR \fInumber\fR
Maximum number of worker threads allowed for this threadpool instance\&.
If a new job is pending and there are no idle worker threads available,
the implementation will try to create new worker thread\&. If the number
of available worker threads is lower than the given number,
new worker thread will start\&. The caller will automatically enter the
event loop and wait until the worker thread has initialized\&. If\&. however,
the number of available worker threads is equal to the given number,
the caller will enter the event loop and wait for the first worker thread
to get idle, thus ready to run the job\&.
Default value of this parameter is 4 (four), which means that the
threadpool instance will allow maximum of 4 worker threads running jobs
or being idle waiting for new jobs to get posted to the job queue\&.
.TP
\fB-idletime\fR \fIseconds\fR
Time in seconds an idle worker thread waits for the job to get posted
to the job queue\&. If no job arrives during this interval and the time
expires, the worker thread will check the number of currently available
worker threads and if the number is higher than the number set by the
\fBminthreads\fR option, it will exit\&.
If an \fBexitscript\fR has been defined, the exiting worker thread
will first run the script and then exit\&. Errors from the exit script,
if any, are ignored\&.
.sp
The idle worker thread is not servicing the event loop\&. If you, however,
put the worker thread into the event loop, by evaluating the
\fBvwait\fR or other related Tcl commands, the worker thread
will not be in the idle state, hence the idle timer will not be
taken into account\&.
Default value for this option is unspecified\&.
.TP
\fB-initcmd\fR \fIscript\fR
Sets a Tcl script used to initialize new worker thread\&. This is usually
used to load packages and commands in the worker, set default variables,
create namespaces, and such\&. If the passed script runs into a Tcl error,
the worker will not be created and the initiating command (either the
\fBtpool::create\fR or \fBtpool::post\fR) will throw error\&.
Default value for this option is unspecified, hence, the Tcl interpreter of
the worker thread will contain just the initial set of Tcl commands\&.
.TP
\fB-exitcmd\fR \fIscript\fR
Sets a Tcl script run when the idle worker thread exits\&. This is normaly
used to cleanup the state of the worker thread, release reserved resources,
cleanup memory and such\&.
Default value for this option is unspecified, thus no Tcl script will run
on the worker thread exit\&.
.RE
.sp
.TP
\fBtpool::names\fR
This command returns a list of IDs of threadpools created with the
\fBtpool::create\fR command\&. If no threadpools were found, the
command will return empty list\&.
.TP
\fBtpool::post\fR ?-detached? ?-nowait? \fItpool\fR \fIscript\fR
This command sends a \fIscript\fR to the target \fItpool\fR threadpool
for execution\&. The script will be executed in the first available idle
worker thread\&. If there are no idle worker threads available, the command
will create new one, enter the event loop and service events until the
newly created thread is initialized\&. If the current number of worker
threads is equal to the maximum number of worker threads, as defined
during the threadpool creation, the command will enter the event loop and
service events while waiting for one of the worker threads to become idle\&.
If the optional ?-nowait? argument is given, the command will not wait
for one idle worker\&. It will just place the job in the pool's job queue
and return immediately\&.
.sp
The command returns the ID of the posted job\&. This ID is used for subsequent
\fBtpool::wait\fR, \fBtpool::get\fR and \fBtpool::cancel\fR commands to wait
for and retrieve result of the posted script, or cancel the posted job
respectively\&. If the optional ?-detached? argument is specified, the
command will post a detached job\&. A detached job can not be cancelled or
waited upon and is not identified by the job ID\&.
.sp
If the threadpool \fItpool\fR is not found in the list of active
thread pools, the command will throw error\&. The error will also be triggered
if the newly created worker thread fails to initialize\&.
.TP
\fBtpool::wait\fR \fItpool\fR \fIjoblist\fR ?varname?
This command waits for one or many jobs, whose job IDs are given in the
\fIjoblist\fR to get processed by the worker thread(s)\&. If none of the
specified jobs are ready, the command will enter the event loop, service
events and wait for the first job to get ready\&.
.sp
The command returns the list of completed job IDs\&. If the optional variable
?varname? is given, it will be set to the list of jobs in the
\fIjoblist\fR which are still pending\&. If the threadpool \fItpool\fR
is not found in the list of active thread pools, the command will throw error\&.
.TP
\fBtpool::cancel\fR \fItpool\fR \fIjoblist\fR ?varname?
This command cancels the previously posted jobs given by the \fIjoblist\fR
to the pool \fItpool\fR\&. Job cancellation succeeds only for job still
waiting to be processed\&. If the job is already being executed by one of
the worker threads, the job will not be cancelled\&.
The command returns the list of cancelled job IDs\&. If the optional variable
?varname? is given, it will be set to the list of jobs in the
\fIjoblist\fR which were not cancelled\&. If the threadpool \fItpool\fR
is not found in the list of active thread pools, the command will throw error\&.
.TP
\fBtpool::get\fR \fItpool\fR \fIjob\fR
This command retrieves the result of the previously posted \fIjob\fR\&.
Only results of jobs waited upon with the \fBtpool::wait\fR command
can be retrieved\&. If the execution of the script resulted in error,
the command will throw the error and update the \fBerrorInfo\fR and
\fBerrorCode\fR variables correspondingly\&. If the pool \fItpool\fR
is not found in the list of threadpools, the command will throw error\&.
If the job \fIjob\fR is not ready for retrieval, because it is currently
being executed by the worker thread, the command will throw error\&.
.TP
\fBtpool::preserve\fR \fItpool\fR
Each call to this command increments the reference counter of the
threadpool \fItpool\fR by one (1)\&. Command returns the value of the
reference counter after the increment\&.
By incrementing the reference counter, the caller signalizes that
he/she wishes to use the resource for a longer period of time\&.
.TP
\fBtpool::release\fR \fItpool\fR
Each call to this command decrements the reference counter of the
threadpool \fItpool\fR by one (1)\&.Command returns the value of the
reference counter after the decrement\&.
When the reference counter reaches zero (0), the threadpool \fItpool\fR
is marked for termination\&. You should not reference the threadpool
after the \fBtpool::release\fR command returns zero\&. The \fItpool\fR
handle goes out of scope and should not be used any more\&. Any following
reference to the same threadpool handle will result in Tcl error\&.
.TP
\fBtpool::suspend\fR \fItpool\fR
Suspends processing work on this queue\&. All pool workers are paused
but additional work can be added to the pool\&. Note that adding the
additional work will not increase the number of workers dynamically
as the pool processing is suspended\&. Number of workers is maintained
to the count that was found prior suspending worker activity\&.
If you need to assure certain number of worker threads, use the
\fBminworkers\fR option of the \fBtpool::create\fR command\&.
.TP
\fBtpool::resume\fR \fItpool\fR
Resume processing work on this queue\&. All paused (suspended)
workers are free to get work from the pool\&. Note that resuming pool
operation will just let already created workers to proceed\&.
It will not create additional worker threads to handle the work
posted to the pool's work queue\&.
.PP
.SH DISCUSSION
Threadpool is one of the most common threading paradigm when it comes
to server applications handling a large number of relatively small tasks\&.
A very simplistic model for building a server application would be to
create a new thread each time a request arrives and service the request
in the new thread\&. One of the disadvantages of this approach is that
the overhead of creating a new thread for each request is significant;
a server that created a new thread for each request would spend more time
and consume more system resources in creating and destroying threads than
in processing actual user requests\&. In addition to the overhead of
creating and destroying threads, active threads consume system resources\&.
Creating too many threads can cause the system to run out of memory or
trash due to excessive memory consumption\&.
.PP
A thread pool offers a solution to both the problem of thread life-cycle
overhead and the problem of resource trashing\&. By reusing threads for
multiple tasks, the thread-creation overhead is spread over many tasks\&.
As a bonus, because the thread already exists when a request arrives,
the delay introduced by thread creation is eliminated\&. Thus, the request
can be serviced immediately\&. Furthermore, by properly tuning the number
of threads in the thread pool, resource thrashing may also be eliminated
by forcing any request to wait until a thread is available to process it\&.
.SH "SEE ALSO"
thread, tsv, ttrace
.SH KEYWORDS
thread, threadpool

628
pkgs/thread2.8.7/doc/man/tsv.n Normal file
View File

@@ -0,0 +1,628 @@
'\"
'\" Generated from file '' by tcllib/doctools with format 'nroff'
'\"
.TH "tsv" n 2\&.8 "Tcl Threading"
.\" The -*- nroff -*- definitions below are for supplemental macros used
.\" in Tcl/Tk manual entries.
.\"
.\" .AP type name in/out ?indent?
.\" Start paragraph describing an argument to a library procedure.
.\" type is type of argument (int, etc.), in/out is either "in", "out",
.\" or "in/out" to describe whether procedure reads or modifies arg,
.\" and indent is equivalent to second arg of .IP (shouldn't ever be
.\" needed; use .AS below instead)
.\"
.\" .AS ?type? ?name?
.\" Give maximum sizes of arguments for setting tab stops. Type and
.\" name are examples of largest possible arguments that will be passed
.\" to .AP later. If args are omitted, default tab stops are used.
.\"
.\" .BS
.\" Start box enclosure. From here until next .BE, everything will be
.\" enclosed in one large box.
.\"
.\" .BE
.\" End of box enclosure.
.\"
.\" .CS
.\" Begin code excerpt.
.\"
.\" .CE
.\" End code excerpt.
.\"
.\" .VS ?version? ?br?
.\" Begin vertical sidebar, for use in marking newly-changed parts
.\" of man pages. The first argument is ignored and used for recording
.\" the version when the .VS was added, so that the sidebars can be
.\" found and removed when they reach a certain age. If another argument
.\" is present, then a line break is forced before starting the sidebar.
.\"
.\" .VE
.\" End of vertical sidebar.
.\"
.\" .DS
.\" Begin an indented unfilled display.
.\"
.\" .DE
.\" End of indented unfilled display.
.\"
.\" .SO ?manpage?
.\" Start of list of standard options for a Tk widget. The manpage
.\" argument defines where to look up the standard options; if
.\" omitted, defaults to "options". The options follow on successive
.\" lines, in three columns separated by tabs.
.\"
.\" .SE
.\" End of list of standard options for a Tk widget.
.\"
.\" .OP cmdName dbName dbClass
.\" Start of description of a specific option. cmdName gives the
.\" option's name as specified in the class command, dbName gives
.\" the option's name in the option database, and dbClass gives
.\" the option's class in the option database.
.\"
.\" .UL arg1 arg2
.\" Print arg1 underlined, then print arg2 normally.
.\"
.\" .QW arg1 ?arg2?
.\" Print arg1 in quotes, then arg2 normally (for trailing punctuation).
.\"
.\" .PQ arg1 ?arg2?
.\" Print an open parenthesis, arg1 in quotes, then arg2 normally
.\" (for trailing punctuation) and then a closing parenthesis.
.\"
.\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages.
.if t .wh -1.3i ^B
.nr ^l \n(.l
.ad b
.\" # Start an argument description
.de AP
.ie !"\\$4"" .TP \\$4
.el \{\
. ie !"\\$2"" .TP \\n()Cu
. el .TP 15
.\}
.ta \\n()Au \\n()Bu
.ie !"\\$3"" \{\
\&\\$1 \\fI\\$2\\fP (\\$3)
.\".b
.\}
.el \{\
.br
.ie !"\\$2"" \{\
\&\\$1 \\fI\\$2\\fP
.\}
.el \{\
\&\\fI\\$1\\fP
.\}
.\}
..
.\" # define tabbing values for .AP
.de AS
.nr )A 10n
.if !"\\$1"" .nr )A \\w'\\$1'u+3n
.nr )B \\n()Au+15n
.\"
.if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n
.nr )C \\n()Bu+\\w'(in/out)'u+2n
..
.AS Tcl_Interp Tcl_CreateInterp in/out
.\" # BS - start boxed text
.\" # ^y = starting y location
.\" # ^b = 1
.de BS
.br
.mk ^y
.nr ^b 1u
.if n .nf
.if n .ti 0
.if n \l'\\n(.lu\(ul'
.if n .fi
..
.\" # BE - end boxed text (draw box now)
.de BE
.nf
.ti 0
.mk ^t
.ie n \l'\\n(^lu\(ul'
.el \{\
.\" Draw four-sided box normally, but don't draw top of
.\" box if the box started on an earlier page.
.ie !\\n(^b-1 \{\
\h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
.\}
.el \}\
\h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
.\}
.\}
.fi
.br
.nr ^b 0
..
.\" # VS - start vertical sidebar
.\" # ^Y = starting y location
.\" # ^v = 1 (for troff; for nroff this doesn't matter)
.de VS
.if !"\\$2"" .br
.mk ^Y
.ie n 'mc \s12\(br\s0
.el .nr ^v 1u
..
.\" # VE - end of vertical sidebar
.de VE
.ie n 'mc
.el \{\
.ev 2
.nf
.ti 0
.mk ^t
\h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n'
.sp -1
.fi
.ev
.\}
.nr ^v 0
..
.\" # Special macro to handle page bottom: finish off current
.\" # box/sidebar if in box/sidebar mode, then invoked standard
.\" # page bottom macro.
.de ^B
.ev 2
'ti 0
'nf
.mk ^t
.if \\n(^b \{\
.\" Draw three-sided box if this is the box's first page,
.\" draw two sides but no top otherwise.
.ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
.el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
.\}
.if \\n(^v \{\
.nr ^x \\n(^tu+1v-\\n(^Yu
\kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c
.\}
.bp
'fi
.ev
.if \\n(^b \{\
.mk ^y
.nr ^b 2
.\}
.if \\n(^v \{\
.mk ^Y
.\}
..
.\" # DS - begin display
.de DS
.RS
.nf
.sp
..
.\" # DE - end display
.de DE
.fi
.RE
.sp
..
.\" # SO - start of list of standard options
.de SO
'ie '\\$1'' .ds So \\fBoptions\\fR
'el .ds So \\fB\\$1\\fR
.SH "STANDARD OPTIONS"
.LP
.nf
.ta 5.5c 11c
.ft B
..
.\" # SE - end of list of standard options
.de SE
.fi
.ft R
.LP
See the \\*(So manual entry for details on the standard options.
..
.\" # OP - start of full description for a single option
.de OP
.LP
.nf
.ta 4c
Command-Line Name: \\fB\\$1\\fR
Database Name: \\fB\\$2\\fR
Database Class: \\fB\\$3\\fR
.fi
.IP
..
.\" # CS - begin code excerpt
.de CS
.RS
.nf
.ta .25i .5i .75i 1i
..
.\" # CE - end code excerpt
.de CE
.fi
.RE
..
.\" # UL - underline word
.de UL
\\$1\l'|0\(ul'\\$2
..
.\" # QW - apply quotation marks to word
.de QW
.ie '\\*(lq'"' ``\\$1''\\$2
.\"" fix emacs highlighting
.el \\*(lq\\$1\\*(rq\\$2
..
.\" # PQ - apply parens and quotation marks to word
.de PQ
.ie '\\*(lq'"' (``\\$1''\\$2)\\$3
.\"" fix emacs highlighting
.el (\\*(lq\\$1\\*(rq\\$2)\\$3
..
.\" # QR - quoted range
.de QR
.ie '\\*(lq'"' ``\\$1''\\-``\\$2''\\$3
.\"" fix emacs highlighting
.el \\*(lq\\$1\\*(rq\\-\\*(lq\\$2\\*(rq\\$3
..
.\" # MT - "empty" string
.de MT
.QW ""
..
.BS
.SH NAME
tsv \- Part of the Tcl threading extension allowing script level manipulation of data shared between threads\&.
.SH SYNOPSIS
package require \fBTcl 8\&.4\fR
.sp
package require \fBThread ?2\&.8?\fR
.sp
\fBtsv::names\fR ?pattern?
.sp
\fBtsv::object\fR \fIvarname\fR \fIelement\fR
.sp
\fBtsv::set\fR \fIvarname\fR \fIelement\fR ?value?
.sp
\fBtsv::get\fR \fIvarname\fR \fIelement\fR ?namedvar?
.sp
\fBtsv::unset\fR \fIvarname\fR ?element?
.sp
\fBtsv::exists\fR \fIvarname\fR \fIelement\fR
.sp
\fBtsv::pop\fR \fIvarname\fR \fIelement\fR
.sp
\fBtsv::move\fR \fIvarname\fR \fIoldname\fR \fInewname\fR
.sp
\fBtsv::incr\fR \fIvarname\fR \fIelement\fR ?count?
.sp
\fBtsv::append\fR \fIvarname\fR \fIelement\fR \fIvalue\fR ?value \&.\&.\&.?
.sp
\fBtsv::lock\fR \fIvarname\fR \fIarg\fR ?arg \&.\&.\&.?
.sp
\fBtsv::handlers\fR
.sp
\fBtsv::lappend\fR \fIvarname\fR \fIelement\fR \fIvalue\fR ?value \&.\&.\&.?
.sp
\fBtsv::linsert\fR \fIvarname\fR \fIelement\fR \fIindex\fR \fIvalue\fR ?value \&.\&.\&.?
.sp
\fBtsv::lreplace\fR \fIvarname\fR \fIelement\fR \fIfirst\fR \fIlast\fR ?value \&.\&.\&.?
.sp
\fBtsv::llength\fR \fIvarname\fR \fIelement\fR
.sp
\fBtsv::lindex\fR \fIvarname\fR \fIelement\fR ?index?
.sp
\fBtsv::lrange\fR \fIvarname\fR \fIelement\fR \fIfrom\fR \fIto\fR
.sp
\fBtsv::lsearch\fR \fIvarname\fR \fIelement\fR ?options? \fIpattern\fR
.sp
\fBtsv::lset\fR \fIvarname\fR \fIelement\fR \fIindex\fR ?index \&.\&.\&.? \fIvalue\fR
.sp
\fBtsv::lpop\fR \fIvarname\fR \fIelement\fR ?index?
.sp
\fBtsv::lpush\fR \fIvarname\fR \fIelement\fR ?index?
.sp
\fBtsv::array set\fR \fIvarname\fR \fIlist\fR
.sp
\fBtsv::array get\fR \fIvarname\fR ?pattern?
.sp
\fBtsv::array names\fR \fIvarname\fR ?pattern?
.sp
\fBtsv::array size\fR \fIvarname\fR
.sp
\fBtsv::array reset\fR \fIvarname\fR \fIlist\fR
.sp
\fBtsv::array bind\fR \fIvarname\fR \fIhandle\fR
.sp
\fBtsv::array unbind\fR \fIvarname\fR
.sp
\fBtsv::array isbound\fR \fIvarname\fR
.sp
\fBtsv::keyldel\fR \fIvarname\fR \fIkeylist\fR \fIkey\fR
.sp
\fBtsv::keylget\fR \fIvarname\fR \fIkeylist\fR \fIkey\fR ?retvar?
.sp
\fBtsv::keylkeys\fR \fIvarname\fR \fIkeylist\fR ?key?
.sp
\fBtsv::keylset\fR \fIvarname\fR \fIkeylist\fR \fIkey\fR \fIvalue\fR ?key value\&.\&.?
.sp
.BE
.SH DESCRIPTION
This section describes commands implementing thread shared variables\&.
A thread shared variable is very similar to a Tcl array but in
contrast to a Tcl array it is created in shared memory and can
be accessed from many threads at the same time\&. Important feature of
thread shared variable is that each access to the variable is internaly
protected by a mutex so script programmer does not have to take care
about locking the variable himself\&.
.PP
Thread shared variables are not bound to any thread explicitly\&. That
means that when a thread which created any of thread shared variables
exits, the variable and associated memory is not unset/reclaimed\&.
User has to explicitly unset the variable to reclaim the memory
consumed by the variable\&.
.SH "ELEMENT COMMANDS"
.TP
\fBtsv::names\fR ?pattern?
Returns names of shared variables matching optional ?pattern?
or all known variables if pattern is ommited\&.
.TP
\fBtsv::object\fR \fIvarname\fR \fIelement\fR
Creates object accessor command for the \fIelement\fR in the
shared variable \fIvarname\fR\&. Using this command, one can apply most
of the other shared variable commands as method functions of
the element object command\&. The object command is automatically
deleted when the element which this command is pointing to is unset\&.
.CS
% tsv::set foo bar "A shared string"
% set string [tsv::object foo bar]
% $string append " appended"
=> A shared string appended
.CE
.TP
\fBtsv::set\fR \fIvarname\fR \fIelement\fR ?value?
Sets the value of the \fIelement\fR in the shared variable \fIvarname\fR
to \fIvalue\fR and returns the value to caller\&. The \fIvalue\fR
may be ommited, in which case the command will return the current
value of the element\&. If the element cannot be found, error is triggered\&.
.TP
\fBtsv::get\fR \fIvarname\fR \fIelement\fR ?namedvar?
Retrieves the value of the \fIelement\fR from the shared variable \fIvarname\fR\&.
If the optional argument \fInamedvar\fR is given, the value is
stored in the named variable\&. Return value of the command depends
of the existence of the optional argument \fInamedvar\fR\&.
If the argument is ommited and the requested element cannot be found
in the shared array, the command triggers error\&. If, however, the
optional argument is given on the command line, the command returns
true (1) if the element is found or false (0) if the element is not found\&.
.TP
\fBtsv::unset\fR \fIvarname\fR ?element?
Unsets the \fIelement\fR from the shared variable \fIvarname\fR\&.
If the optional element is not given, it deletes the variable\&.
.TP
\fBtsv::exists\fR \fIvarname\fR \fIelement\fR
Checks wether the \fIelement\fR exists in the shared variable \fIvarname\fR
and returns true (1) if it does or false (0) if it doesn't\&.
.TP
\fBtsv::pop\fR \fIvarname\fR \fIelement\fR
Returns value of the \fIelement\fR in the shared variable \fIvarname\fR
and unsets the element, all in one atomic operation\&.
.TP
\fBtsv::move\fR \fIvarname\fR \fIoldname\fR \fInewname\fR
Renames the element \fIoldname\fR to the \fInewname\fR in the
shared variable \fIvarname\fR\&. This effectively performs an get/unset/set
sequence of operations but all in one atomic step\&.
.TP
\fBtsv::incr\fR \fIvarname\fR \fIelement\fR ?count?
Similar to standard Tcl \fBincr\fR command but increments the value
of the \fIelement\fR in shared variaboe \fIvarname\fR instead of
the Tcl variable\&.
.TP
\fBtsv::append\fR \fIvarname\fR \fIelement\fR \fIvalue\fR ?value \&.\&.\&.?
Similar to standard Tcl \fBappend\fR command but appends one or more
values to the \fIelement\fR in shared variable \fIvarname\fR instead of the
Tcl variable\&.
.TP
\fBtsv::lock\fR \fIvarname\fR \fIarg\fR ?arg \&.\&.\&.?
This command concatenates passed arguments and evaluates the
resulting script under the internal mutex protection\&. During the
script evaluation, the entire shared variable is locked\&. For shared
variable commands within the script, internal locking is disabled
so no deadlock can occur\&. It is also allowed to unset the shared
variable from within the script\&. The shared variable is automatically
created if it did not exists at the time of the first lock operation\&.
.CS
% tsv::lock foo {
tsv::lappend foo bar 1
tsv::lappend foo bar 2
puts stderr [tsv::set foo bar]
tsv::unset foo
}
.CE
.TP
\fBtsv::handlers\fR
Returns the names of all persistent storage handlers enabled at compile time\&.
See \fBARRAY COMMANDS\fR for details\&.
.PP
.SH "LIST COMMANDS"
Those command are similar to the equivalently named Tcl command\&. The difference
is that they operate on elements of shared arrays\&.
.TP
\fBtsv::lappend\fR \fIvarname\fR \fIelement\fR \fIvalue\fR ?value \&.\&.\&.?
Similar to standard Tcl \fBlappend\fR command but appends one
or more values to the \fIelement\fR in shared variable \fIvarname\fR
instead of the Tcl variable\&.
.TP
\fBtsv::linsert\fR \fIvarname\fR \fIelement\fR \fIindex\fR \fIvalue\fR ?value \&.\&.\&.?
Similar to standard Tcl \fBlinsert\fR command but inserts one
or more values at the \fIindex\fR list position in the
\fIelement\fR in the shared variable \fIvarname\fR instead of the Tcl variable\&.
.TP
\fBtsv::lreplace\fR \fIvarname\fR \fIelement\fR \fIfirst\fR \fIlast\fR ?value \&.\&.\&.?
Similar to standard Tcl \fBlreplace\fR command but replaces one
or more values between the \fIfirst\fR and \fIlast\fR position
in the \fIelement\fR of the shared variable \fIvarname\fR instead of
the Tcl variable\&.
.TP
\fBtsv::llength\fR \fIvarname\fR \fIelement\fR
Similar to standard Tcl \fBllength\fR command but returns length
of the \fIelement\fR in the shared variable \fIvarname\fR instead of the Tcl
variable\&.
.TP
\fBtsv::lindex\fR \fIvarname\fR \fIelement\fR ?index?
Similar to standard Tcl \fBlindex\fR command but returns the value
at the \fIindex\fR list position of the \fIelement\fR from
the shared variable \fIvarname\fR instead of the Tcl variable\&.
.TP
\fBtsv::lrange\fR \fIvarname\fR \fIelement\fR \fIfrom\fR \fIto\fR
Similar to standard Tcl \fBlrange\fR command but returns values
between \fIfrom\fR and \fIto\fR list positions from the
\fIelement\fR in the shared variable \fIvarname\fR instead of the Tcl variable\&.
.TP
\fBtsv::lsearch\fR \fIvarname\fR \fIelement\fR ?options? \fIpattern\fR
Similar to standard Tcl \fBlsearch\fR command but searches the \fIelement\fR
in the shared variable \fIvarname\fR instead of the Tcl variable\&.
.TP
\fBtsv::lset\fR \fIvarname\fR \fIelement\fR \fIindex\fR ?index \&.\&.\&.? \fIvalue\fR
Similar to standard Tcl \fBlset\fR command but sets the \fIelement\fR
in the shared variable \fIvarname\fR instead of the Tcl variable\&.
.TP
\fBtsv::lpop\fR \fIvarname\fR \fIelement\fR ?index?
Similar to the standard Tcl \fBlindex\fR command but in addition to
returning, it also splices the value out of the \fIelement\fR
from the shared variable \fIvarname\fR in one atomic operation\&.
In contrast to the Tcl \fBlindex\fR command, this command returns
no value to the caller\&.
.TP
\fBtsv::lpush\fR \fIvarname\fR \fIelement\fR ?index?
This command performes the opposite of the \fBtsv::lpop\fR command\&.
As its counterpart, it returns no value to the caller\&.
.PP
.SH "ARRAY COMMANDS"
This command supports most of the options of the standard Tcl
\fBarray\fR command\&. In addition to those, it allows binding
a shared variable to some persisten storage databases\&. Currently the persistent
options supported are the famous GNU Gdbm and LMDB\&. These options have to be
selected during the package compilation time\&.
The implementation provides hooks for defining other persistency layers, if
needed\&.
.TP
\fBtsv::array set\fR \fIvarname\fR \fIlist\fR
Does the same as standard Tcl \fBarray set\fR\&.
.TP
\fBtsv::array get\fR \fIvarname\fR ?pattern?
Does the same as standard Tcl \fBarray get\fR\&.
.TP
\fBtsv::array names\fR \fIvarname\fR ?pattern?
Does the same as standard Tcl \fBarray names\fR\&.
.TP
\fBtsv::array size\fR \fIvarname\fR
Does the same as standard Tcl \fBarray size\fR\&.
.TP
\fBtsv::array reset\fR \fIvarname\fR \fIlist\fR
Does the same as standard Tcl \fBarray set\fR but it clears
the \fIvarname\fR and sets new values from the list atomically\&.
.TP
\fBtsv::array bind\fR \fIvarname\fR \fIhandle\fR
Binds the \fIvarname\fR to the persistent storage \fIhandle\fR\&.
The format of the \fIhandle\fR is <handler>:<address>, where <handler> is
"gdbm" for GNU Gdbm and "lmdb" for LMDB and <address> is the path to the
database file\&.
.TP
\fBtsv::array unbind\fR \fIvarname\fR
Unbinds the shared \fIarray\fR from its bound persistent storage\&.
.TP
\fBtsv::array isbound\fR \fIvarname\fR
Returns true (1) if the shared \fIvarname\fR is bound to some
persistent storage or zero (0) if not\&.
.PP
.SH "KEYED LIST COMMANDS"
Keyed list commands are borrowed from the TclX package\&. Keyed lists provide
a structured data type built upon standard Tcl lists\&. This is a functionality
similar to structs in the C programming language\&.
.PP
A keyed list is a list in which each element contains a key and value
pair\&. These element pairs are stored as lists themselves, where the key
is the first element of the list, and the value is the second\&. The
key-value pairs are referred to as fields\&. This is an example of a
keyed list:
.CS
{{NAME {Frank Zappa}} {JOB {musician and composer}}}
.CE
Fields may contain subfields; `\&.' is the separator character\&. Subfields
are actually fields where the value is another keyed list\&. Thus the
following list has the top level fields ID and NAME, and subfields
NAME\&.FIRST and NAME\&.LAST:
.CS
{ID 106} {NAME {{FIRST Frank} {LAST Zappa}}}
.CE
There is no limit to the recursive depth of subfields,
allowing one to build complex data structures\&. Keyed lists are constructed
and accessed via a number of commands\&. All keyed list management
commands take the name of the variable containing the keyed list as an
argument (i\&.e\&. passed by reference), rather than passing the list directly\&.
.TP
\fBtsv::keyldel\fR \fIvarname\fR \fIkeylist\fR \fIkey\fR
Delete the field specified by \fIkey\fR from the keyed list \fIkeylist\fR
in the shared variable \fIvarname\fR\&.
This removes both the key and the value from the keyed list\&.
.TP
\fBtsv::keylget\fR \fIvarname\fR \fIkeylist\fR \fIkey\fR ?retvar?
Return the value associated with \fIkey\fR from the keyed list \fIkeylist\fR
in the shared variable \fIvarname\fR\&.
If the optional \fIretvar\fR is not specified, then the value will be
returned as the result of the command\&. In this case, if key is not found
in the list, an error will result\&.
.sp
If \fIretvar\fR is specified and \fIkey\fR is in the list, then the value
is returned in the variable \fIretvar\fR and the command returns 1 if the
key was present within the list\&. If \fIkey\fR isn't in the list, the
command will return 0, and \fIretvar\fR will be left unchanged\&. If {} is
specified for \fIretvar\fR, the value is not returned, allowing the Tcl
programmer to determine if a \fIkey\fR is present in a keyed list without
setting a variable as a side-effect\&.
.TP
\fBtsv::keylkeys\fR \fIvarname\fR \fIkeylist\fR ?key?
Return the a list of the keys in the keyed list \fIkeylist\fR in the
shared variable \fIvarname\fR\&. If \fIkey\fR is specified, then it is
the name of a key field who's subfield keys are to be retrieved\&.
.TP
\fBtsv::keylset\fR \fIvarname\fR \fIkeylist\fR \fIkey\fR \fIvalue\fR ?key value\&.\&.?
Set the value associated with \fIkey\fR, in the keyed list \fIkeylist\fR
to \fIvalue\fR\&. If the \fIkeylist\fR does not exists, it is created\&.
If \fIkey\fR is not currently in the list, it will be added\&. If it already
exists, \fIvalue\fR replaces the existing value\&. Multiple keywords and
values may be specified, if desired\&.
.PP
.SH DISCUSSION
The current implementation of thread shared variables allows for easy and
convenient access to data shared between different threads\&.
Internally, the data is stored in Tcl objects and all package commands
operate on internal data representation, thus minimizing shimmering and
improving performance\&. Special care has been taken to assure that all
object data is properly locked and deep-copied when moving objects between
threads\&.
.PP
Due to the internal design of the Tcl core, there is no provision of full
integration of shared variables within the Tcl syntax, unfortunately\&. All
access to shared data must be performed with the supplied package commands\&.
Also, variable traces are not supported\&. But even so, benefits of easy,
simple and safe shared data manipulation outweights imposed limitations\&.
.SH CREDITS
Thread shared variables are inspired by the nsv interface found in
AOLserver, a highly scalable Web server from America Online\&.
.SH "SEE ALSO"
thread, tpool, ttrace
.SH KEYWORDS
locking, synchronization, thread shared data, threads

506
pkgs/thread2.8.7/doc/man/ttrace.n Normal file
View File

@@ -0,0 +1,506 @@
'\"
'\" Generated from file '' by tcllib/doctools with format 'nroff'
'\"
.TH "ttrace" n 2\&.8 "Tcl Threading"
.\" The -*- nroff -*- definitions below are for supplemental macros used
.\" in Tcl/Tk manual entries.
.\"
.\" .AP type name in/out ?indent?
.\" Start paragraph describing an argument to a library procedure.
.\" type is type of argument (int, etc.), in/out is either "in", "out",
.\" or "in/out" to describe whether procedure reads or modifies arg,
.\" and indent is equivalent to second arg of .IP (shouldn't ever be
.\" needed; use .AS below instead)
.\"
.\" .AS ?type? ?name?
.\" Give maximum sizes of arguments for setting tab stops. Type and
.\" name are examples of largest possible arguments that will be passed
.\" to .AP later. If args are omitted, default tab stops are used.
.\"
.\" .BS
.\" Start box enclosure. From here until next .BE, everything will be
.\" enclosed in one large box.
.\"
.\" .BE
.\" End of box enclosure.
.\"
.\" .CS
.\" Begin code excerpt.
.\"
.\" .CE
.\" End code excerpt.
.\"
.\" .VS ?version? ?br?
.\" Begin vertical sidebar, for use in marking newly-changed parts
.\" of man pages. The first argument is ignored and used for recording
.\" the version when the .VS was added, so that the sidebars can be
.\" found and removed when they reach a certain age. If another argument
.\" is present, then a line break is forced before starting the sidebar.
.\"
.\" .VE
.\" End of vertical sidebar.
.\"
.\" .DS
.\" Begin an indented unfilled display.
.\"
.\" .DE
.\" End of indented unfilled display.
.\"
.\" .SO ?manpage?
.\" Start of list of standard options for a Tk widget. The manpage
.\" argument defines where to look up the standard options; if
.\" omitted, defaults to "options". The options follow on successive
.\" lines, in three columns separated by tabs.
.\"
.\" .SE
.\" End of list of standard options for a Tk widget.
.\"
.\" .OP cmdName dbName dbClass
.\" Start of description of a specific option. cmdName gives the
.\" option's name as specified in the class command, dbName gives
.\" the option's name in the option database, and dbClass gives
.\" the option's class in the option database.
.\"
.\" .UL arg1 arg2
.\" Print arg1 underlined, then print arg2 normally.
.\"
.\" .QW arg1 ?arg2?
.\" Print arg1 in quotes, then arg2 normally (for trailing punctuation).
.\"
.\" .PQ arg1 ?arg2?
.\" Print an open parenthesis, arg1 in quotes, then arg2 normally
.\" (for trailing punctuation) and then a closing parenthesis.
.\"
.\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages.
.if t .wh -1.3i ^B
.nr ^l \n(.l
.ad b
.\" # Start an argument description
.de AP
.ie !"\\$4"" .TP \\$4
.el \{\
. ie !"\\$2"" .TP \\n()Cu
. el .TP 15
.\}
.ta \\n()Au \\n()Bu
.ie !"\\$3"" \{\
\&\\$1 \\fI\\$2\\fP (\\$3)
.\".b
.\}
.el \{\
.br
.ie !"\\$2"" \{\
\&\\$1 \\fI\\$2\\fP
.\}
.el \{\
\&\\fI\\$1\\fP
.\}
.\}
..
.\" # define tabbing values for .AP
.de AS
.nr )A 10n
.if !"\\$1"" .nr )A \\w'\\$1'u+3n
.nr )B \\n()Au+15n
.\"
.if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n
.nr )C \\n()Bu+\\w'(in/out)'u+2n
..
.AS Tcl_Interp Tcl_CreateInterp in/out
.\" # BS - start boxed text
.\" # ^y = starting y location
.\" # ^b = 1
.de BS
.br
.mk ^y
.nr ^b 1u
.if n .nf
.if n .ti 0
.if n \l'\\n(.lu\(ul'
.if n .fi
..
.\" # BE - end boxed text (draw box now)
.de BE
.nf
.ti 0
.mk ^t
.ie n \l'\\n(^lu\(ul'
.el \{\
.\" Draw four-sided box normally, but don't draw top of
.\" box if the box started on an earlier page.
.ie !\\n(^b-1 \{\
\h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
.\}
.el \}\
\h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
.\}
.\}
.fi
.br
.nr ^b 0
..
.\" # VS - start vertical sidebar
.\" # ^Y = starting y location
.\" # ^v = 1 (for troff; for nroff this doesn't matter)
.de VS
.if !"\\$2"" .br
.mk ^Y
.ie n 'mc \s12\(br\s0
.el .nr ^v 1u
..
.\" # VE - end of vertical sidebar
.de VE
.ie n 'mc
.el \{\
.ev 2
.nf
.ti 0
.mk ^t
\h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n'
.sp -1
.fi
.ev
.\}
.nr ^v 0
..
.\" # Special macro to handle page bottom: finish off current
.\" # box/sidebar if in box/sidebar mode, then invoked standard
.\" # page bottom macro.
.de ^B
.ev 2
'ti 0
'nf
.mk ^t
.if \\n(^b \{\
.\" Draw three-sided box if this is the box's first page,
.\" draw two sides but no top otherwise.
.ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
.el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
.\}
.if \\n(^v \{\
.nr ^x \\n(^tu+1v-\\n(^Yu
\kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c
.\}
.bp
'fi
.ev
.if \\n(^b \{\
.mk ^y
.nr ^b 2
.\}
.if \\n(^v \{\
.mk ^Y
.\}
..
.\" # DS - begin display
.de DS
.RS
.nf
.sp
..
.\" # DE - end display
.de DE
.fi
.RE
.sp
..
.\" # SO - start of list of standard options
.de SO
'ie '\\$1'' .ds So \\fBoptions\\fR
'el .ds So \\fB\\$1\\fR
.SH "STANDARD OPTIONS"
.LP
.nf
.ta 5.5c 11c
.ft B
..
.\" # SE - end of list of standard options
.de SE
.fi
.ft R
.LP
See the \\*(So manual entry for details on the standard options.
..
.\" # OP - start of full description for a single option
.de OP
.LP
.nf
.ta 4c
Command-Line Name: \\fB\\$1\\fR
Database Name: \\fB\\$2\\fR
Database Class: \\fB\\$3\\fR
.fi
.IP
..
.\" # CS - begin code excerpt
.de CS
.RS
.nf
.ta .25i .5i .75i 1i
..
.\" # CE - end code excerpt
.de CE
.fi
.RE
..
.\" # UL - underline word
.de UL
\\$1\l'|0\(ul'\\$2
..
.\" # QW - apply quotation marks to word
.de QW
.ie '\\*(lq'"' ``\\$1''\\$2
.\"" fix emacs highlighting
.el \\*(lq\\$1\\*(rq\\$2
..
.\" # PQ - apply parens and quotation marks to word
.de PQ
.ie '\\*(lq'"' (``\\$1''\\$2)\\$3
.\"" fix emacs highlighting
.el (\\*(lq\\$1\\*(rq\\$2)\\$3
..
.\" # QR - quoted range
.de QR
.ie '\\*(lq'"' ``\\$1''\\-``\\$2''\\$3
.\"" fix emacs highlighting
.el \\*(lq\\$1\\*(rq\\-\\*(lq\\$2\\*(rq\\$3
..
.\" # MT - "empty" string
.de MT
.QW ""
..
.BS
.SH NAME
ttrace \- Trace-based interpreter initialization
.SH SYNOPSIS
package require \fBTcl 8\&.4\fR
.sp
package require \fBThread ?2\&.8?\fR
.sp
\fBttrace::eval\fR \fIarg\fR ?arg \&.\&.\&.?
.sp
\fBttrace::enable\fR
.sp
\fBttrace::disable\fR
.sp
\fBttrace::cleanup\fR
.sp
\fBttrace::update\fR ?epoch?
.sp
\fBttrace::getscript\fR
.sp
\fBttrace::atenable\fR \fIcmd\fR \fIarglist\fR \fIbody\fR
.sp
\fBttrace::atdisable\fR \fIcmd\fR \fIarglist\fR \fIbody\fR
.sp
\fBttrace::addtrace\fR \fIcmd\fR \fIarglist\fR \fIbody\fR
.sp
\fBttrace::addscript\fR \fIname\fR \fIbody\fR
.sp
\fBttrace::addresolver\fR \fIcmd\fR \fIarglist\fR \fIbody\fR
.sp
\fBttrace::addcleanup\fR \fIbody\fR
.sp
\fBttrace::addentry\fR \fIcmd\fR \fIvar\fR \fIval\fR
.sp
\fBttrace::getentry\fR \fIcmd\fR \fIvar\fR
.sp
\fBttrace::getentries\fR \fIcmd\fR ?pattern?
.sp
\fBttrace::delentry\fR \fIcmd\fR
.sp
\fBttrace::preload\fR \fIcmd\fR
.sp
.BE
.SH DESCRIPTION
This package creates a framework for on-demand replication of the
interpreter state accross threads in an multithreading application\&.
It relies on the mechanics of Tcl command tracing and the Tcl
\fBunknown\fR command and mechanism\&.
.PP
The package requires Tcl threading extension but can be alternatively
used stand-alone within the AOLserver, a scalable webserver from
America Online\&.
.PP
In a nutshell, a short sample illustrating the usage of the ttrace
with the Tcl threading extension:
.CS
% package require Ttrace
2\&.8\&.0
% set t1 [thread::create {package require Ttrace; thread::wait}]
tid0x1802800
% ttrace::eval {proc test args {return test-[thread::id]}}
% thread::send $t1 test
test-tid0x1802800
% set t2 [thread::create {package require Ttrace; thread::wait}]
tid0x1804000
% thread::send $t2 test
test-tid0x1804000
.CE
.PP
As seen from above, the \fBttrace::eval\fR and \fBttrace::update\fR
commands are used to create a thread-wide definition of a simple
Tcl procedure and replicate that definition to all, already existing
or later created, threads\&.
.SH "USER COMMANDS"
This section describes user-level commands\&. Those commands can be
used by script writers to control the execution of the tracing
framework\&.
.TP
\fBttrace::eval\fR \fIarg\fR ?arg \&.\&.\&.?
This command concatenates given arguments and evaluates the resulting
Tcl command with trace framework enabled\&. If the command execution
was ok, it takes necessary steps to automatically propagate the
trace epoch change to all threads in the application\&.
For AOLserver, only newly created threads actually receive the
epoch change\&. For the Tcl threading extension, all threads created by
the extension are automatically updated\&. If the command execution
resulted in Tcl error, no state propagation takes place\&.
.sp
This is the most important user-level command of the package as
it wraps most of the commands described below\&. This greatly
simplifies things, because user need to learn just this (one)
command in order to effectively use the package\&. Other commands,
as desribed below, are included mostly for the sake of completeness\&.
.TP
\fBttrace::enable\fR
Activates all registered callbacks in the framework
and starts a new trace epoch\&. The trace epoch encapsulates all
changes done to the interpreter during the time traces are activated\&.
.TP
\fBttrace::disable\fR
Deactivates all registered callbacks in the framework
and closes the current trace epoch\&.
.TP
\fBttrace::cleanup\fR
Used to clean-up all on-demand loaded resources in the interpreter\&.
It effectively brings Tcl interpreter to its pristine state\&.
.TP
\fBttrace::update\fR ?epoch?
Used to refresh the state of the interpreter to match the optional
trace ?epoch?\&. If the optional ?epoch? is not given, it takes
the most recent trace epoch\&.
.TP
\fBttrace::getscript\fR
Returns a synthetized Tcl script which may be sourced in any interpreter\&.
This script sets the stage for the Tcl \fBunknown\fR command so it can
load traced resources from the in-memory database\&. Normally, this command
is automatically invoked by other higher-level commands like
\fBttrace::eval\fR and \fBttrace::update\fR\&.
.PP
.SH "CALLBACK COMMANDS"
A word upfront: the package already includes callbacks for tracing
following Tcl commands: \fBproc\fR, \fBnamespace\fR, \fBvariable\fR,
\fBload\fR, and \fBrename\fR\&. Additionaly, a set of callbacks for
tracing resources (object, clasess) for the XOTcl v1\&.3\&.8+, an
OO-extension to Tcl, is also provided\&.
This gives a solid base for solving most of the real-life needs and
serves as an example for people wanting to customize the package
to cover their specific needs\&.
.PP
Below, you can find commands for registering callbacks in the
framework and for writing callback scripts\&. These callbacks are
invoked by the framework in order to gather interpreter state
changes, build in-memory database, perform custom-cleanups and
various other tasks\&.
.TP
\fBttrace::atenable\fR \fIcmd\fR \fIarglist\fR \fIbody\fR
Registers Tcl callback to be activated at \fBttrace::enable\fR\&.
Registered callbacks are activated on FIFO basis\&. The callback
definition includes the name of the callback, \fIcmd\fR, a list
of callback arguments, \fIarglist\fR and the \fIbody\fR of the
callback\&. Effectively, this actually resembles the call interface
of the standard Tcl \fBproc\fR command\&.
.TP
\fBttrace::atdisable\fR \fIcmd\fR \fIarglist\fR \fIbody\fR
Registers Tcl callback to be activated at \fBttrace::disable\fR\&.
Registered callbacks are activated on FIFO basis\&. The callback
definition includes the name of the callback, \fIcmd\fR, a list
of callback arguments, \fIarglist\fR and the \fIbody\fR of the
callback\&. Effectively, this actually resembles the call interface
of the standard Tcl \fBproc\fR command\&.
.TP
\fBttrace::addtrace\fR \fIcmd\fR \fIarglist\fR \fIbody\fR
Registers Tcl callback to be activated for tracing the Tcl
\fBcmd\fR command\&. The callback definition includes the name of
the Tcl command to trace, \fIcmd\fR, a list of callback arguments,
\fIarglist\fR and the \fIbody\fR of the callback\&. Effectively,
this actually resembles the call interface of the standard Tcl
\fBproc\fR command\&.
.TP
\fBttrace::addscript\fR \fIname\fR \fIbody\fR
Registers Tcl callback to be activated for building a Tcl
script to be passed to other interpreters\&. This script is
used to set the stage for the Tcl \fBunknown\fR command\&.
Registered callbacks are activated on FIFO basis\&.
The callback definition includes the name of the callback,
\fIname\fR and the \fIbody\fR of the callback\&.
.TP
\fBttrace::addresolver\fR \fIcmd\fR \fIarglist\fR \fIbody\fR
Registers Tcl callback to be activated by the overloaded Tcl
\fBunknown\fR command\&.
Registered callbacks are activated on FIFO basis\&.
This callback is used to resolve the resource and load the
resource in the current interpreter\&.
.TP
\fBttrace::addcleanup\fR \fIbody\fR
Registers Tcl callback to be activated by the \fBtrace::cleanup\fR\&.
Registered callbacks are activated on FIFO basis\&.
.TP
\fBttrace::addentry\fR \fIcmd\fR \fIvar\fR \fIval\fR
Adds one entry to the named in-memory database\&.
.TP
\fBttrace::getentry\fR \fIcmd\fR \fIvar\fR
Returns the value of the entry from the named in-memory database\&.
.TP
\fBttrace::getentries\fR \fIcmd\fR ?pattern?
Returns names of all entries from the named in-memory database\&.
.TP
\fBttrace::delentry\fR \fIcmd\fR
Deletes an entry from the named in-memory database\&.
.TP
\fBttrace::preload\fR \fIcmd\fR
Registers the Tcl command to be loaded in the interpreter\&.
Commands registered this way will always be the part of
the interpreter and not be on-demand loaded by the Tcl
\fBunknown\fR command\&.
.PP
.SH DISCUSSION
Common introspective state-replication approaches use a custom Tcl
script to introspect the running interpreter and synthesize another
Tcl script to replicate this state in some other interpreter\&.
This package, on the contrary, uses Tcl command traces\&. Command
traces are registered on selected Tcl commands, like \fBproc\fR,
\fBnamespace\fR, \fBload\fR and other standard (and/or user-defined)
Tcl commands\&. When activated, those traces build an in-memory
database of created resources\&. This database is used as a resource
repository for the (overloaded) Tcl \fBunknown\fR command which
creates the requested resource in the interpreter on demand\&.
This way, users can update just one interpreter (master) in one
thread and replicate that interpreter state (or part of it) to other
threads/interpreters in the process\&.
.PP
Immediate benefit of such approach is the much smaller memory footprint
of the application and much faster thread creation\&. By not actually
loading all necessary procedures (and other resources) in every thread
at the thread initialization time, but by deffering this to the time the
resource is actually referenced, significant improvements in both
memory consumption and thread initialization time can be achieved\&. Some
tests have shown that memory footprint of an multithreading Tcl application
went down more than three times and thread startup time was reduced for
about 50 times\&. Note that your mileage may vary\&.
Other benefits include much finer control about what (and when) gets
replicated from the master to other Tcl thread/interpreters\&.
.SH "SEE ALSO"
thread, tpool, tsv
.SH KEYWORDS
command tracing, introspection

611
pkgs/thread2.8.7/doc/thread.man Normal file
View File

@@ -0,0 +1,611 @@
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin thread n 2.8]
[moddesc {Tcl Threading}]
[titledesc {Extension for script access to Tcl threading}]
[require Tcl 8.4]
[require Thread [opt 2.8]]
[description]
The [package thread] extension creates threads that contain Tcl
interpreters, and it lets you send scripts to those threads for
evaluation.
Additionally, it provides script-level access to basic thread
synchronization primitives, like mutexes and condition variables.
[section COMMANDS]
This section describes commands for creating and destroying threads
and sending scripts to threads for evaluation.
[list_begin definitions]
[call [cmd thread::create] [opt -joinable] [opt -preserved] [opt script]]
This command creates a thread that contains a Tcl interpreter.
The Tcl interpreter either evaluates the optional [option script], if
specified, or it waits in the event loop for scripts that arrive via
the [cmd thread::send] command. The result, if any, of the
optional [option script] is never returned to the caller.
The result of [cmd thread::create] is the ID of the thread. This is
the opaque handle which identifies the newly created thread for
all other package commands. The handle of the thread goes out of scope
automatically when thread is marked for exit
(see the [cmd thread::release] command below).
[para]
If the optional [option script] argument contains the [cmd thread::wait]
command the thread will enter into the event loop. If such command is not
found in the [option script] the thread will run the [option script] to
the end and exit. In that case, the handle may be safely ignored since it
refers to a thread which does not exists any more at the time when the
command returns.
[para]
Using flag [option -joinable] it is possible to create a joinable
thread, i.e. one upon whose exit can be waited upon by using
[cmd thread::join] command.
Note that failure to join a thread created with [option -joinable] flag
results in resource and memory leaks.
[para]
Threads created by the [cmd thread::create] cannot be destroyed
forcefully. Consequently, there is no corresponding thread destroy
command. A thread may only be released using the [cmd thread::release]
and if its internal reference count drops to zero, the thread is
marked for exit. This kicks the thread out of the event loop
servicing and the thread continues to execute commands passed in
the [option script] argument, following the [cmd thread::wait]
command. If this was the last command in the script, as usually the
case, the thread will exit.
[para]
It is possible to create a situation in which it may be impossible
to terminate the thread, for example by putting some endless loop
after the [cmd thread::wait] or entering the event loop again by
doing an vwait-type of command. In such cases, the thread may never
exit. This is considered to be a bad practice and should be avoided
if possible. This is best illustrated by the example below:
[example {
# You should never do ...
set tid [thread::create {
package require Http
thread::wait
vwait forever ; # <-- this!
}]
}]
The thread created in the above example will never be able to exit.
After it has been released with the last matching [cmd thread::release]
call, the thread will jump out of the [cmd thread::wait] and continue
to execute commands following. It will enter [cmd vwait] command and
wait endlessly for events. There is no way one can terminate such thread,
so you wouldn't want to do this!
[para]
Each newly created has its internal reference counter set to 0 (zero),
i.e. it is unreserved. This counter gets incremented by a call to
[cmd thread::preserve] and decremented by a call to [cmd thread::release]
command. These two commands implement simple but effective thread
reservation system and offer predictable and controllable thread
termination capabilities. It is however possible to create initially
preserved threads by using flag [option -preserved] of the
[cmd thread::create] command. Threads created with this flag have the
initial value of the reference counter of 1 (one), and are thus
initially marked reserved.
[call [cmd thread::preserve] [opt id]]
This command increments the thread reference counter. Each call
to this command increments the reference counter by one (1).
Command returns the value of the reference counter after the increment.
If called with the optional thread [option id], the command preserves
the given thread. Otherwise the current thread is preserved.
[para]
With reference counting, one can implement controlled access to a
shared Tcl thread. By incrementing the reference counter, the
caller signalizes that he/she wishes to use the thread for a longer
period of time. By decrementing the counter, caller signalizes that
he/she has finished using the thread.
[call [cmd thread::release] [opt -wait] [opt id]]
This command decrements the thread reference counter. Each call to
this command decrements the reference counter by one (1).
If called with the optional thread [option id], the command releases
the given thread. Otherwise, the current thread is released.
Command returns the value of the reference counter after the decrement.
When the reference counter reaches zero (0), the target thread is
marked for termination. You should not reference the thread after the
[cmd thread::release] command returns zero or negative integer.
The handle of the thread goes out of scope and should not be used any
more. Any following reference to the same thread handle will result
in Tcl error.
[para]
Optional flag [option -wait] instructs the caller thread to wait for
the target thread to exit, if the effect of the command would result
in termination of the target thread, i.e. if the return result would
be zero (0). Without the flag, the caller thread does not wait for
the target thread to exit. Care must be taken when using the
[option -wait], since this may block the caller thread indefinitely.
This option has been implemented for some special uses of the extension
and is deprecated for regular use. Regular users should create joinable
threads by using the [option -joinable] option of the [cmd thread::create]
command and the [cmd thread::join] to wait for thread to exit.
[call [cmd thread::id]]
This command returns the ID of the current thread.
[call [cmd thread::errorproc] [opt procname]]
This command sets a handler for errors that occur in scripts sent
asynchronously, using the [option -async] flag of the
[cmd thread::send] command, to other threads. If no handler
is specified, the current handler is returned. The empty string
resets the handler to default (unspecified) value.
An uncaught error in a thread causes an error message to be sent
to the standard error channel. This default reporting scheme can
be changed by registering a procedure which is called to report
the error. The [arg procname] is called in the interpreter that
invoked the [cmd thread::errorproc] command. The [arg procname]
is called like this:
[example {
myerrorproc thread_id errorInfo
}]
[call [cmd thread::cancel] [opt -unwind] [arg id] [opt result]]
This command requires Tcl version 8.6 or higher.
[para]
Cancels the script being evaluated in the thread given by the [arg id]
parameter. Without the [option -unwind] switch the evaluation stack for
the interpreter is unwound until an enclosing catch command is found or
there are no further invocations of the interpreter left on the call
stack. With the [option -unwind] switch the evaluation stack for the
interpreter is unwound without regard to any intervening catch command
until there are no further invocations of the interpreter left on the
call stack. If [arg result] is present, it will be used as the error
message string; otherwise, a default error message string will be used.
[call [cmd thread::unwind]]
Use of this command is deprecated in favour of more advanced thread
reservation system implemented with [cmd thread::preserve] and
[cmd thread::release] commands. Support for [cmd thread::unwind]
command will disappear in some future major release of the extension.
[para]
This command stops a prior [cmd thread::wait] command. Execution of
the script passed to newly created thread will continue from the
[cmd thread::wait] command. If [cmd thread::wait] was the last command
in the script, the thread will exit. The command returns empty result
but may trigger Tcl error with the message "target thread died" in some
situations.
[call [cmd thread::exit] [opt status]]
Use of this command is deprecated in favour of more advanced thread
reservation system implemented with [cmd thread::preserve] and
[cmd thread::release] commands. Support for [cmd thread::exit]
command will disappear in some future major release of the extension.
[para]
This command forces a thread stuck in the [cmd thread::wait] command to
unconditionally exit. The thread's exit status defaults to 666 and can be
specified using the optional [arg status] argument. The execution of
[cmd thread::exit] command is guaranteed to leave the program memory in the
inconsistent state, produce memory leaks and otherwise affect other subsystem(s)
of the Tcl application in an unpredictable manner. The command returns empty
result but may trigger Tcl error with the message "target thread died" in some
situations.
[call [cmd thread::names]]
This command returns a list of thread IDs. These are only for
threads that have been created via [cmd thread::create] command.
If your application creates other threads at the C level, they
are not reported by this command.
[call [cmd thread::exists] [arg id]]
Returns true (1) if thread given by the [arg id] parameter exists,
false (0) otherwise. This applies only for threads that have
been created via [cmd thread::create] command.
[call [cmd thread::send] [opt -async] [opt -head] [arg id] [arg script] [opt varname]]
This command passes a [arg script] to another thread and, optionally,
waits for the result. If the [option -async] flag is specified, the
command does not wait for the result and it returns empty string.
The target thread must enter it's event loop in order to receive
scripts sent via this command. This is done by default for threads
created without a startup script. Threads can enter the event loop
explicitly by calling [cmd thread::wait] or any other relevant Tcl/Tk
command, like [cmd update], [cmd vwait], etc.
[para]
Optional [option varname] specifies name of the variable to store
the result of the [arg script]. Without the [option -async] flag,
the command returns the evaluation code, similarly to the standard
Tcl [cmd catch] command. If, however, the [option -async] flag is
specified, the command returns immediately and caller can later
[cmd vwait] on [opt varname] to get the result of the passed [arg script]
[example {
set t1 [thread::create]
set t2 [thread::create]
thread::send -async $t1 "set a 1" result
thread::send -async $t2 "set b 2" result
for {set i 0} {$i < 2} {incr i} {
vwait result
}
}]
In the above example, two threads were fed work and both of them were
instructed to signalize the same variable "result" in the calling thread.
The caller entered the event loop twice to get both results. Note,
however, that the order of the received results may vary, depending on
the current system load, type of work done, etc, etc.
[para]
Many threads can simultaneously send scripts to the target thread for
execution. All of them are entered into the event queue of the target
thread and executed on the FIFO basis, intermingled with optional other
events pending in the event queue of the target thread.
Using the optional [opt -head] switch, scripts posted to the thread's
event queue can be placed on the head, instead on the tail of the queue,
thus being executed in the LIFO fashion.
[call [cmd thread::broadcast] [arg script]]
This command passes a [arg script] to all threads created by the
package for execution. It does not wait for response from any of
the threads.
[call [cmd thread::wait]]
This enters the event loop so a thread can receive messages from
the [cmd thread::send] command. This command should only be used
within the script passed to the [cmd thread::create]. It should
be the very last command in the script. If this is not the case,
the exiting thread will continue executing the script lines past
the [cmd thread::wait] which is usually not what you want and/or
expect.
[example {
set t1 [thread::create {
#
# Do some initialization work here
#
thread::wait ; # Enter the event loop
}]
}]
[call [cmd thread::eval] [opt {-lock mutex}] [arg arg] [opt {arg ...}]]
This command concatenates passed arguments and evaluates the
resulting script under the mutex protection. If no mutex is
specified by using the [opt {-lock mutex}] optional argument,
the internal static mutex is used.
[call [cmd thread::join] [arg id]]
This command waits for the thread with ID [arg id] to exit and
then returns it's exit code. Errors will be returned for threads
which are not joinable or already waited upon by another thread.
Upon the join the handle of the thread has gone out of scope and
should not be used any more.
[call [cmd thread::configure] [arg id] [opt option] [opt value] [opt ...]]
This command configures various low-level aspects of the thread with
ID [arg id] in the similar way as the standard Tcl command
[cmd fconfigure] configures some Tcl channel options. Options currently
supported are: [option -eventmark] and [option -unwindonerror].
[para]
The [option -eventmark] option, when set, limits the number of
asynchronously posted scripts to the thread event loop.
The [cmd {thread::send -async}] command will block until the number
of pending scripts in the event loop does not drop below the value
configured with [option -eventmark]. Default value for the
[option -eventmark] is 0 (zero) which effectively disables the checking,
i.e. allows for unlimited number of posted scripts.
[para]
The [option -unwindonerror] option, when set, causes the
target thread to unwind if the result of the script processing
resulted in error. Default value for the [option -unwindonerror]
is 0 (false), i.e. thread continues to process scripts after one
of the posted scripts fails.
[call [cmd thread::transfer] [arg id] [arg channel]]
This moves the specified [arg channel] from the current thread
and interpreter to the main interpreter of the thread with the
given [arg id]. After the move the current interpreter has no
access to the channel any more, but the main interpreter of the
target thread will be able to use it from now on.
The command waits until the other thread has incorporated the
channel. Because of this it is possible to deadlock the
participating threads by commanding the other through a
synchronous [cmd thread::send] to transfer a channel to us.
This easily extends into longer loops of threads waiting for
each other. Other restrictions: the channel in question must
not be shared among multiple interpreters running in the
sending thread. This automatically excludes the special channels
for standard input, output and error.
[para]
Due to the internal Tcl core implementation and the restriction on
transferring shared channels, one has to take extra measures when
transferring socket channels created by accepting the connection
out of the [cmd socket] commands callback procedures:
[example {
socket -server _Accept 2200
proc _Accept {s ipaddr port} {
after idle [list Accept $s $ipaddr $port]
}
proc Accept {s ipaddr port} {
set tid [thread::create]
thread::transfer $tid $s
}
}]
[call [cmd thread::detach] [arg channel]]
This detaches the specified [arg channel] from the current thread and
interpreter. After that, the current interpreter has no access to the
channel any more. The channel is in the parked state until some other
(or the same) thread attaches the channel again with [cmd thread::attach].
Restrictions: same as for transferring shared channels with the
[cmd thread::transfer] command.
[call [cmd thread::attach] [arg channel]]
This attaches the previously detached [arg channel] in the
current thread/interpreter. For already existing channels,
the command does nothing, i.e. it is not an error to attach the
same channel more than once. The first operation will actually
perform the operation, while all subsequent operation will just
do nothing. Command throws error if the [arg channel] cannot be
found in the list of detached channels and/or in the current
interpreter.
[call [cmd thread::mutex]]
Mutexes are most common thread synchronization primitives.
They are used to synchronize access from two or more threads to one or
more shared resources. This command provides script-level access to
exclusive and/or recursive mutexes. Exclusive mutexes can be locked
only once by one thread, while recursive mutexes can be locked many
times by the same thread. For recursive mutexes, number of lock and
unlock operations must match, otherwise, the mutex will never be
released, which would lead to various deadlock situations.
[para]
Care has to be taken when using mutexes in an multithreading program.
Improper use of mutexes may lead to various deadlock situations,
especially when using exclusive mutexes.
[para]
The [cmd thread::mutex] command supports following subcommands and options:
[list_begin definitions]
[call [cmd thread::mutex] [method create] [opt -recursive]]
Creates the mutex and returns it's opaque handle. This handle
should be used for any future reference to the newly created mutex.
If no optional [opt -recursive] argument was specified, the command
creates the exclusive mutex. With the [opt -recursive] argument,
the command creates a recursive mutex.
[call [cmd thread::mutex] [method destroy] [arg mutex]]
Destroys the [arg mutex]. Mutex should be in unlocked state before
the destroy attempt. If the mutex is locked, the command will throw
Tcl error.
[call [cmd thread::mutex] [method lock] [arg mutex]]
Locks the [arg mutex]. Locking the exclusive mutex may throw Tcl
error if on attempt to lock the same mutex twice from the same
thread. If your program logic forces you to lock the same mutex
twice or more from the same thread (this may happen in recursive
procedure invocations) you should consider using the recursive mutexes.
[call [cmd thread::mutex] [method unlock] [arg mutex]]
Unlocks the [arg mutex] so some other thread may lock it again.
Attempt to unlock the already unlocked mutex will throw Tcl error.
[list_end]
[para]
[call [cmd thread::rwmutex]]
This command creates many-readers/single-writer mutexes. Reader/writer
mutexes allow you to serialize access to a shared resource more optimally.
In situations where a shared resource gets mostly read and seldom modified,
you might gain some performance by using reader/writer mutexes instead of
exclusive or recursive mutexes.
[para]
For reading the resource, thread should obtain a read lock on the resource.
Read lock is non-exclusive, meaning that more than one thread can
obtain a read lock to the same resource, without waiting on other readers.
For changing the resource, however, a thread must obtain a exclusive
write lock. This lock effectively blocks all threads from gaining the
read-lock while the resource is been modified by the writer thread.
Only after the write lock has been released, the resource may be read-locked
again.
[para]
The [cmd thread::rwmutex] command supports following subcommands and options:
[list_begin definitions]
[call [cmd thread::rwmutex] [method create]]
Creates the reader/writer mutex and returns it's opaque handle.
This handle should be used for any future reference to the newly
created mutex.
[call [cmd thread::rwmutex] [method destroy] [arg mutex]]
Destroys the reader/writer [arg mutex]. If the mutex is already locked,
attempt to destroy it will throw Tcl error.
[call [cmd thread::rwmutex] [method rlock] [arg mutex]]
Locks the [arg mutex] for reading. More than one thread may read-lock
the same [arg mutex] at the same time.
[call [cmd thread::rwmutex] [method wlock] [arg mutex]]
Locks the [arg mutex] for writing. Only one thread may write-lock
the same [arg mutex] at the same time. Attempt to write-lock same
[arg mutex] twice from the same thread will throw Tcl error.
[call [cmd thread::rwmutex] [method unlock] [arg mutex]]
Unlocks the [arg mutex] so some other thread may lock it again.
Attempt to unlock already unlocked [arg mutex] will throw Tcl error.
[list_end]
[para]
[call [cmd thread::cond]]
This command provides script-level access to condition variables.
A condition variable creates a safe environment for the program
to test some condition, sleep on it when false and be awakened
when it might have become true. A condition variable is always
used in the conjunction with an exclusive mutex. If you attempt
to use other type of mutex in conjunction with the condition
variable, a Tcl error will be thrown.
[para]
The command supports following subcommands and options:
[list_begin definitions]
[call [cmd thread::cond] [method create]]
Creates the condition variable and returns it's opaque handle.
This handle should be used for any future reference to newly
created condition variable.
[call [cmd thread::cond] [method destroy] [arg cond]]
Destroys condition variable [arg cond]. Extreme care has to be taken
that nobody is using (i.e. waiting on) the condition variable,
otherwise unexpected errors may happen.
[call [cmd thread::cond] [method notify] [arg cond]]
Wakes up all threads waiting on the condition variable [arg cond].
[call [cmd thread::cond] [method wait] [arg cond] [arg mutex] [opt ms]]
This command is used to suspend program execution until the condition
variable [arg cond] has been signalled or the optional timer has expired.
The exclusive [arg mutex] must be locked by the calling thread on entrance
to this command. If the mutex is not locked, Tcl error is thrown.
While waiting on the [arg cond], the command releases [arg mutex].
Before returning to the calling thread, the command re-acquires the
[arg mutex] again. Unlocking the [arg mutex] and waiting on the
condition variable [arg cond] is done atomically.
[para]
The [option ms] command option, if given, must be an integer specifying
time interval in milliseconds the command waits to be signalled.
Otherwise the command waits on condition notify forever.
[para]
In multithreading programs, there are many situations where a thread has
to wait for some event to happen until it is allowed to proceed.
This is usually accomplished by repeatedly testing a condition under the
mutex protection and waiting on the condition variable until the condition
evaluates to true:
[example {
set mutex [thread::mutex create]
set cond [thread::cond create]
thread::mutex lock $mutex
while {<some_condition_is_true>} {
thread::cond wait $cond $mutex
}
# Do some work under mutex protection
thread::mutex unlock $mutex
}]
Repeated testing of the condition is needed since the condition variable
may get signalled without the condition being actually changed (spurious
thread wake-ups, for example).
[list_end]
[list_end]
[section DISCUSSION]
The fundamental threading model in Tcl is that there can be one or
more Tcl interpreters per thread, but each Tcl interpreter should
only be used by a single thread which created it.
A "shared memory" abstraction is awkward to provide in Tcl because
Tcl makes assumptions about variable and data ownership. Therefore
this extension supports a simple form of threading where the main
thread can manage several background, or "worker" threads.
For example, an event-driven server can pass requests to worker
threads, and then await responses from worker threads or new client
requests. Everything goes through the common Tcl event loop, so
message passing between threads works naturally with event-driven I/O,
[cmd vwait] on variables, and so forth. For the transfer of bulk
information it is possible to move channels between the threads.
[para]
For advanced multithreading scripts, script-level access to two
basic synchronization primitives, mutex and condition variables,
is also supported.
[see_also tsv tpool ttrace [uri http://www.tcl.tk/doc/howto/thread_model.html]]
[keywords thread events {message passing} synchronization mutex]
[manpage_end]

225
pkgs/thread2.8.7/doc/tpool.man Normal file
View File

@@ -0,0 +1,225 @@
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin tpool n 2.8]
[moddesc {Tcl Threading}]
[titledesc {Part of the Tcl threading extension implementing pools of worker threads.}]
[require Tcl 8.4]
[require Thread [opt 2.8]]
[description]
This package creates and manages pools of worker threads. It allows you
to post jobs to worker threads and wait for their completion. The
threadpool implementation is Tcl event-loop aware. That means that any
time a caller is forced to wait for an event (job being completed or
a worker thread becoming idle or initialized), the implementation will
enter the event loop and allow for servicing of other pending file or
timer (or any other supported) events.
[section COMMANDS]
[list_begin definitions]
[call [cmd tpool::create] [opt options]]
This command creates new threadpool. It accepts several options as
key-value pairs. Options are used to tune some threadpool parameters.
The command returns the ID of the newly created threadpool.
[para]
Following options are supported:
[list_begin options]
[opt_def -minworkers [arg number]]
Minimum number of worker threads needed for this threadpool instance.
During threadpool creation, the implementation will create somany
worker threads upfront and will keep at least number of them alive
during the lifetime of the threadpool instance.
Default value of this parameter is 0 (zero). which means that a newly
threadpool will have no worker threads initially. All worker threads
will be started on demand by callers running [cmd tpool::post] command
and posting jobs to the job queue.
[opt_def -maxworkers [arg number]]
Maximum number of worker threads allowed for this threadpool instance.
If a new job is pending and there are no idle worker threads available,
the implementation will try to create new worker thread. If the number
of available worker threads is lower than the given number,
new worker thread will start. The caller will automatically enter the
event loop and wait until the worker thread has initialized. If. however,
the number of available worker threads is equal to the given number,
the caller will enter the event loop and wait for the first worker thread
to get idle, thus ready to run the job.
Default value of this parameter is 4 (four), which means that the
threadpool instance will allow maximum of 4 worker threads running jobs
or being idle waiting for new jobs to get posted to the job queue.
[opt_def -idletime [arg seconds]]
Time in seconds an idle worker thread waits for the job to get posted
to the job queue. If no job arrives during this interval and the time
expires, the worker thread will check the number of currently available
worker threads and if the number is higher than the number set by the
[option minthreads] option, it will exit.
If an [option exitscript] has been defined, the exiting worker thread
will first run the script and then exit. Errors from the exit script,
if any, are ignored.
[para]
The idle worker thread is not servicing the event loop. If you, however,
put the worker thread into the event loop, by evaluating the
[cmd vwait] or other related Tcl commands, the worker thread
will not be in the idle state, hence the idle timer will not be
taken into account.
Default value for this option is unspecified.
[opt_def -initcmd [arg script]]
Sets a Tcl script used to initialize new worker thread. This is usually
used to load packages and commands in the worker, set default variables,
create namespaces, and such. If the passed script runs into a Tcl error,
the worker will not be created and the initiating command (either the
[cmd tpool::create] or [cmd tpool::post]) will throw error.
Default value for this option is unspecified, hence, the Tcl interpreter of
the worker thread will contain just the initial set of Tcl commands.
[opt_def -exitcmd [arg script]]
Sets a Tcl script run when the idle worker thread exits. This is normally
used to cleanup the state of the worker thread, release reserved resources,
cleanup memory and such.
Default value for this option is unspecified, thus no Tcl script will run
on the worker thread exit.
[list_end]
[para]
[call [cmd tpool::names]]
This command returns a list of IDs of threadpools created with the
[cmd tpool::create] command. If no threadpools were found, the
command will return empty list.
[call [cmd tpool::post] [opt -detached] [opt -nowait] [arg tpool] [arg script]]
This command sends a [arg script] to the target [arg tpool] threadpool
for execution. The script will be executed in the first available idle
worker thread. If there are no idle worker threads available, the command
will create new one, enter the event loop and service events until the
newly created thread is initialized. If the current number of worker
threads is equal to the maximum number of worker threads, as defined
during the threadpool creation, the command will enter the event loop and
service events while waiting for one of the worker threads to become idle.
If the optional [opt -nowait] argument is given, the command will not wait
for one idle worker. It will just place the job in the pool's job queue
and return immediately.
[para]
The command returns the ID of the posted job. This ID is used for subsequent
[cmd tpool::wait], [cmd tpool::get] and [cmd tpool::cancel] commands to wait
for and retrieve result of the posted script, or cancel the posted job
respectively. If the optional [opt -detached] argument is specified, the
command will post a detached job. A detached job can not be cancelled or
waited upon and is not identified by the job ID.
[para]
If the threadpool [arg tpool] is not found in the list of active
thread pools, the command will throw error. The error will also be triggered
if the newly created worker thread fails to initialize.
[call [cmd tpool::wait] [arg tpool] [arg joblist] [opt varname]]
This command waits for one or many jobs, whose job IDs are given in the
[arg joblist] to get processed by the worker thread(s). If none of the
specified jobs are ready, the command will enter the event loop, service
events and wait for the first job to get ready.
[para]
The command returns the list of completed job IDs. If the optional variable
[opt varname] is given, it will be set to the list of jobs in the
[arg joblist] which are still pending. If the threadpool [arg tpool]
is not found in the list of active thread pools, the command will throw error.
[call [cmd tpool::cancel] [arg tpool] [arg joblist] [opt varname]]
This command cancels the previously posted jobs given by the [arg joblist]
to the pool [arg tpool]. Job cancellation succeeds only for job still
waiting to be processed. If the job is already being executed by one of
the worker threads, the job will not be cancelled.
The command returns the list of cancelled job IDs. If the optional variable
[opt varname] is given, it will be set to the list of jobs in the
[arg joblist] which were not cancelled. If the threadpool [arg tpool]
is not found in the list of active thread pools, the command will throw error.
[call [cmd tpool::get] [arg tpool] [arg job]]
This command retrieves the result of the previously posted [arg job].
Only results of jobs waited upon with the [cmd tpool::wait] command
can be retrieved. If the execution of the script resulted in error,
the command will throw the error and update the [var errorInfo] and
[var errorCode] variables correspondingly. If the pool [arg tpool]
is not found in the list of threadpools, the command will throw error.
If the job [arg job] is not ready for retrieval, because it is currently
being executed by the worker thread, the command will throw error.
[call [cmd tpool::preserve] [arg tpool]]
Each call to this command increments the reference counter of the
threadpool [arg tpool] by one (1). Command returns the value of the
reference counter after the increment.
By incrementing the reference counter, the caller signalizes that
he/she wishes to use the resource for a longer period of time.
[call [cmd tpool::release] [arg tpool]]
Each call to this command decrements the reference counter of the
threadpool [arg tpool] by one (1).Command returns the value of the
reference counter after the decrement.
When the reference counter reaches zero (0), the threadpool [arg tpool]
is marked for termination. You should not reference the threadpool
after the [cmd tpool::release] command returns zero. The [arg tpool]
handle goes out of scope and should not be used any more. Any following
reference to the same threadpool handle will result in Tcl error.
[call [cmd tpool::suspend] [arg tpool]]
Suspends processing work on this queue. All pool workers are paused
but additional work can be added to the pool. Note that adding the
additional work will not increase the number of workers dynamically
as the pool processing is suspended. Number of workers is maintained
to the count that was found prior suspending worker activity.
If you need to assure certain number of worker threads, use the
[option minworkers] option of the [cmd tpool::create] command.
[call [cmd tpool::resume] [arg tpool]]
Resume processing work on this queue. All paused (suspended)
workers are free to get work from the pool. Note that resuming pool
operation will just let already created workers to proceed.
It will not create additional worker threads to handle the work
posted to the pool's work queue.
[list_end]
[section DISCUSSION]
Threadpool is one of the most common threading paradigm when it comes
to server applications handling a large number of relatively small tasks.
A very simplistic model for building a server application would be to
create a new thread each time a request arrives and service the request
in the new thread. One of the disadvantages of this approach is that
the overhead of creating a new thread for each request is significant;
a server that created a new thread for each request would spend more time
and consume more system resources in creating and destroying threads than
in processing actual user requests. In addition to the overhead of
creating and destroying threads, active threads consume system resources.
Creating too many threads can cause the system to run out of memory or
trash due to excessive memory consumption.
[para]
A thread pool offers a solution to both the problem of thread life-cycle
overhead and the problem of resource trashing. By reusing threads for
multiple tasks, the thread-creation overhead is spread over many tasks.
As a bonus, because the thread already exists when a request arrives,
the delay introduced by thread creation is eliminated. Thus, the request
can be serviced immediately. Furthermore, by properly tuning the number
of threads in the thread pool, resource thrashing may also be eliminated
by forcing any request to wait until a thread is available to process it.
[see_also tsv ttrace thread]
[keywords thread threadpool]
[manpage_end]

336
pkgs/thread2.8.7/doc/tsv.man Normal file
View File

@@ -0,0 +1,336 @@
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin tsv n 2.8]
[moddesc {Tcl Threading}]
[titledesc {Part of the Tcl threading extension allowing script level manipulation of data shared between threads.}]
[require Tcl 8.4]
[require Thread [opt 2.8]]
[description]
This section describes commands implementing thread shared variables.
A thread shared variable is very similar to a Tcl array but in
contrast to a Tcl array it is created in shared memory and can
be accessed from many threads at the same time. Important feature of
thread shared variable is that each access to the variable is internally
protected by a mutex so script programmer does not have to take care
about locking the variable himself.
[para]
Thread shared variables are not bound to any thread explicitly. That
means that when a thread which created any of thread shared variables
exits, the variable and associated memory is not unset/reclaimed.
User has to explicitly unset the variable to reclaim the memory
consumed by the variable.
[section {ELEMENT COMMANDS}]
[list_begin definitions]
[call [cmd tsv::names] [opt pattern]]
Returns names of shared variables matching optional [opt pattern]
or all known variables if pattern is omitted.
[call [cmd tsv::object] [arg varname] [arg element]]
Creates object accessor command for the [arg element] in the
shared variable [arg varname]. Using this command, one can apply most
of the other shared variable commands as method functions of
the element object command. The object command is automatically
deleted when the element which this command is pointing to is unset.
[example {
% tsv::set foo bar "A shared string"
% set string [tsv::object foo bar]
% $string append " appended"
=> A shared string appended
}]
[call [cmd tsv::set] [arg varname] [arg element] [opt value]]
Sets the value of the [arg element] in the shared variable [arg varname]
to [arg value] and returns the value to caller. The [arg value]
may be omitted, in which case the command will return the current
value of the element. If the element cannot be found, error is triggered.
[call [cmd tsv::get] [arg varname] [arg element] [opt namedvar]]
Retrieves the value of the [arg element] from the shared variable [arg varname].
If the optional argument [arg namedvar] is given, the value is
stored in the named variable. Return value of the command depends
of the existence of the optional argument [arg namedvar].
If the argument is omitted and the requested element cannot be found
in the shared array, the command triggers error. If, however, the
optional argument is given on the command line, the command returns
true (1) if the element is found or false (0) if the element is not found.
[call [cmd tsv::unset] [arg varname] [opt element]]
Unsets the [arg element] from the shared variable [arg varname].
If the optional element is not given, it deletes the variable.
[call [cmd tsv::exists] [arg varname] [arg element]]
Checks whether the [arg element] exists in the shared variable [arg varname]
and returns true (1) if it does or false (0) if it doesn't.
[call [cmd tsv::pop] [arg varname] [arg element]]
Returns value of the [arg element] in the shared variable [arg varname]
and unsets the element, all in one atomic operation.
[call [cmd tsv::move] [arg varname] [arg oldname] [arg newname]]
Renames the element [arg oldname] to the [arg newname] in the
shared variable [arg varname]. This effectively performs an get/unset/set
sequence of operations but all in one atomic step.
[call [cmd tsv::incr] [arg varname] [arg element] [opt count]]
Similar to standard Tcl [cmd incr] command but increments the value
of the [arg element] in shared variable [arg varname] instead of
the Tcl variable.
[call [cmd tsv::append] [arg varname] [arg element] [arg value] [opt {value ...}]]
Similar to standard Tcl [cmd append] command but appends one or more
values to the [arg element] in shared variable [arg varname] instead of the
Tcl variable.
[call [cmd tsv::lock] [arg varname] [arg arg] [opt {arg ...}]]
This command concatenates passed arguments and evaluates the
resulting script under the internal mutex protection. During the
script evaluation, the entire shared variable is locked. For shared
variable commands within the script, internal locking is disabled
so no deadlock can occur. It is also allowed to unset the shared
variable from within the script. The shared variable is automatically
created if it did not exists at the time of the first lock operation.
[example {
% tsv::lock foo {
tsv::lappend foo bar 1
tsv::lappend foo bar 2
puts stderr [tsv::set foo bar]
tsv::unset foo
}
}]
[call [cmd tsv::handlers]]
Returns the names of all persistent storage handlers enabled at compile time.
See [sectref {ARRAY COMMANDS}] for details.
[list_end]
[section {LIST COMMANDS}]
Those command are similar to the equivalently named Tcl command. The difference
is that they operate on elements of shared arrays.
[list_begin definitions]
[call [cmd tsv::lappend] [arg varname] [arg element] [arg value] [opt {value ...}]]
Similar to standard Tcl [cmd lappend] command but appends one
or more values to the [arg element] in shared variable [arg varname]
instead of the Tcl variable.
[call [cmd tsv::linsert] [arg varname] [arg element] [arg index] [arg value] [opt {value ...}]]
Similar to standard Tcl [cmd linsert] command but inserts one
or more values at the [arg index] list position in the
[arg element] in the shared variable [arg varname] instead of the Tcl variable.
[call [cmd tsv::lreplace] [arg varname] [arg element] [arg first] [arg last] [opt {value ...}]]
Similar to standard Tcl [cmd lreplace] command but replaces one
or more values between the [arg first] and [arg last] position
in the [arg element] of the shared variable [arg varname] instead of
the Tcl variable.
[call [cmd tsv::llength] [arg varname] [arg element]]
Similar to standard Tcl [cmd llength] command but returns length
of the [arg element] in the shared variable [arg varname] instead of the Tcl
variable.
[call [cmd tsv::lindex] [arg varname] [arg element] [opt index]]
Similar to standard Tcl [cmd lindex] command but returns the value
at the [arg index] list position of the [arg element] from
the shared variable [arg varname] instead of the Tcl variable.
[call [cmd tsv::lrange] [arg varname] [arg element] [arg from] [arg to]]
Similar to standard Tcl [cmd lrange] command but returns values
between [arg from] and [arg to] list positions from the
[arg element] in the shared variable [arg varname] instead of the Tcl variable.
[call [cmd tsv::lsearch] [arg varname] [arg element] [opt options] [arg pattern]]
Similar to standard Tcl [cmd lsearch] command but searches the [arg element]
in the shared variable [arg varname] instead of the Tcl variable.
[call [cmd tsv::lset] [arg varname] [arg element] [arg index] [opt {index ...}] [arg value]]
Similar to standard Tcl [cmd lset] command but sets the [arg element]
in the shared variable [arg varname] instead of the Tcl variable.
[call [cmd tsv::lpop] [arg varname] [arg element] [opt index]]
Similar to the standard Tcl [cmd lindex] command but in addition to
returning, it also splices the value out of the [arg element]
from the shared variable [arg varname] in one atomic operation.
In contrast to the Tcl [cmd lindex] command, this command returns
no value to the caller.
[call [cmd tsv::lpush] [arg varname] [arg element] [opt index]]
This command performs the opposite of the [cmd tsv::lpop] command.
As its counterpart, it returns no value to the caller.
[list_end]
[section {ARRAY COMMANDS}]
This command supports most of the options of the standard Tcl
[cmd array] command. In addition to those, it allows binding
a shared variable to some persistent storage databases. Currently the persistent
options supported are the famous GNU Gdbm and LMDB. These options have to be
selected during the package compilation time.
The implementation provides hooks for defining other persistency layers, if
needed.
[list_begin definitions]
[call [cmd {tsv::array set}] [arg varname] [arg list]]
Does the same as standard Tcl [cmd {array set}].
[call [cmd {tsv::array get}] [arg varname] [opt pattern]]
Does the same as standard Tcl [cmd {array get}].
[call [cmd {tsv::array names}] [arg varname] [opt pattern]]
Does the same as standard Tcl [cmd {array names}].
[call [cmd {tsv::array size}] [arg varname]]
Does the same as standard Tcl [cmd {array size}].
[call [cmd {tsv::array reset}] [arg varname] [arg list]]
Does the same as standard Tcl [cmd {array set}] but it clears
the [arg varname] and sets new values from the list atomically.
[call [cmd {tsv::array bind}] [arg varname] [arg handle]]
Binds the [arg varname] to the persistent storage [arg handle].
The format of the [arg handle] is <handler>:<address>, where <handler> is
"gdbm" for GNU Gdbm and "lmdb" for LMDB and <address> is the path to the
database file.
[call [cmd {tsv::array unbind}] [arg varname]]
Unbinds the shared [arg array] from its bound persistent storage.
[call [cmd {tsv::array isbound}] [arg varname]]
Returns true (1) if the shared [arg varname] is bound to some
persistent storage or zero (0) if not.
[list_end]
[section {KEYED LIST COMMANDS}]
Keyed list commands are borrowed from the TclX package. Keyed lists provide
a structured data type built upon standard Tcl lists. This is a functionality
similar to structs in the C programming language.
[para]
A keyed list is a list in which each element contains a key and value
pair. These element pairs are stored as lists themselves, where the key
is the first element of the list, and the value is the second. The
key-value pairs are referred to as fields. This is an example of a
keyed list:
[example {
{{NAME {Frank Zappa}} {JOB {musician and composer}}}
}]
Fields may contain subfields; `.' is the separator character. Subfields
are actually fields where the value is another keyed list. Thus the
following list has the top level fields ID and NAME, and subfields
NAME.FIRST and NAME.LAST:
[example {
{ID 106} {NAME {{FIRST Frank} {LAST Zappa}}}
}]
There is no limit to the recursive depth of subfields,
allowing one to build complex data structures. Keyed lists are constructed
and accessed via a number of commands. All keyed list management
commands take the name of the variable containing the keyed list as an
argument (i.e. passed by reference), rather than passing the list directly.
[list_begin definitions]
[call [cmd tsv::keyldel] [arg varname] [arg keylist] [arg key]]
Delete the field specified by [arg key] from the keyed list [arg keylist]
in the shared variable [arg varname].
This removes both the key and the value from the keyed list.
[call [cmd tsv::keylget] [arg varname] [arg keylist] [arg key] [opt retvar]]
Return the value associated with [arg key] from the keyed list [arg keylist]
in the shared variable [arg varname].
If the optional [arg retvar] is not specified, then the value will be
returned as the result of the command. In this case, if key is not found
in the list, an error will result.
[para]
If [arg retvar] is specified and [arg key] is in the list, then the value
is returned in the variable [arg retvar] and the command returns 1 if the
key was present within the list. If [arg key] isn't in the list, the
command will return 0, and [arg retvar] will be left unchanged. If {} is
specified for [arg retvar], the value is not returned, allowing the Tcl
programmer to determine if a [arg key] is present in a keyed list without
setting a variable as a side-effect.
[call [cmd tsv::keylkeys] [arg varname] [arg keylist] [opt key]]
Return the a list of the keys in the keyed list [arg keylist] in the
shared variable [arg varname]. If [arg key] is specified, then it is
the name of a key field whose subfield keys are to be retrieved.
[call [cmd tsv::keylset] [arg varname] [arg keylist] [arg key] [arg value] [opt {key value..}]]
Set the value associated with [arg key], in the keyed list [arg keylist]
to [arg value]. If the [arg keylist] does not exists, it is created.
If [arg key] is not currently in the list, it will be added. If it already
exists, [arg value] replaces the existing value. Multiple keywords and
values may be specified, if desired.
[list_end]
[section DISCUSSION]
The current implementation of thread shared variables allows for easy and
convenient access to data shared between different threads.
Internally, the data is stored in Tcl objects and all package commands
operate on internal data representation, thus minimizing shimmering and
improving performance. Special care has been taken to assure that all
object data is properly locked and deep-copied when moving objects between
threads.
[para]
Due to the internal design of the Tcl core, there is no provision of full
integration of shared variables within the Tcl syntax, unfortunately. All
access to shared data must be performed with the supplied package commands.
Also, variable traces are not supported. But even so, benefits of easy,
simple and safe shared data manipulation outweighs imposed limitations.
[section CREDITS]
Thread shared variables are inspired by the nsv interface found in
AOLserver, a highly scalable Web server from America Online.
[see_also tpool ttrace thread]
[keywords threads synchronization locking {thread shared data}]
[manpage_end]

230
pkgs/thread2.8.7/doc/ttrace.man Normal file
View File

@@ -0,0 +1,230 @@
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin ttrace n 2.8]
[moddesc {Tcl Threading}]
[titledesc {Trace-based interpreter initialization}]
[require Tcl 8.4]
[require Thread [opt 2.8]]
[description]
This package creates a framework for on-demand replication of the
interpreter state across threads in an multithreading application.
It relies on the mechanics of Tcl command tracing and the Tcl
[cmd unknown] command and mechanism.
[para]
The package requires Tcl threading extension but can be alternatively
used stand-alone within the AOLserver, a scalable webserver from
America Online.
[para]
In a nutshell, a short sample illustrating the usage of the ttrace
with the Tcl threading extension:
[example {
% package require Ttrace
2.8.2
% set t1 [thread::create {package require Ttrace; thread::wait}]
tid0x1802800
% ttrace::eval {proc test args {return test-[thread::id]}}
% thread::send $t1 test
test-tid0x1802800
% set t2 [thread::create {package require Ttrace; thread::wait}]
tid0x1804000
% thread::send $t2 test
test-tid0x1804000
}]
[para]
As seen from above, the [cmd ttrace::eval] and [cmd ttrace::update]
commands are used to create a thread-wide definition of a simple
Tcl procedure and replicate that definition to all, already existing
or later created, threads.
[section {USER COMMANDS}]
This section describes user-level commands. Those commands can be
used by script writers to control the execution of the tracing
framework.
[list_begin definitions]
[call [cmd ttrace::eval] [arg arg] [opt {arg ...}]]
This command concatenates given arguments and evaluates the resulting
Tcl command with trace framework enabled. If the command execution
was ok, it takes necessary steps to automatically propagate the
trace epoch change to all threads in the application.
For AOLserver, only newly created threads actually receive the
epoch change. For the Tcl threading extension, all threads created by
the extension are automatically updated. If the command execution
resulted in Tcl error, no state propagation takes place.
[para]
This is the most important user-level command of the package as
it wraps most of the commands described below. This greatly
simplifies things, because user need to learn just this (one)
command in order to effectively use the package. Other commands,
as described below, are included mostly for the sake of completeness.
[call [cmd ttrace::enable]]
Activates all registered callbacks in the framework
and starts a new trace epoch. The trace epoch encapsulates all
changes done to the interpreter during the time traces are activated.
[call [cmd ttrace::disable]]
Deactivates all registered callbacks in the framework
and closes the current trace epoch.
[call [cmd ttrace::cleanup]]
Used to clean-up all on-demand loaded resources in the interpreter.
It effectively brings Tcl interpreter to its pristine state.
[call [cmd ttrace::update] [opt epoch]]
Used to refresh the state of the interpreter to match the optional
trace [opt epoch]. If the optional [opt epoch] is not given, it takes
the most recent trace epoch.
[call [cmd ttrace::getscript]]
Returns a synthesized Tcl script which may be sourced in any interpreter.
This script sets the stage for the Tcl [cmd unknown] command so it can
load traced resources from the in-memory database. Normally, this command
is automatically invoked by other higher-level commands like
[cmd ttrace::eval] and [cmd ttrace::update].
[list_end]
[section {CALLBACK COMMANDS}]
A word upfront: the package already includes callbacks for tracing
following Tcl commands: [cmd proc], [cmd namespace], [cmd variable],
[cmd load], and [cmd rename]. Additionally, a set of callbacks for
tracing resources (object, classes) for the XOTcl v1.3.8+, an
OO-extension to Tcl, is also provided.
This gives a solid base for solving most of the real-life needs and
serves as an example for people wanting to customize the package
to cover their specific needs.
[para]
Below, you can find commands for registering callbacks in the
framework and for writing callback scripts. These callbacks are
invoked by the framework in order to gather interpreter state
changes, build in-memory database, perform custom-cleanups and
various other tasks.
[list_begin definitions]
[call [cmd ttrace::atenable] [arg cmd] [arg arglist] [arg body]]
Registers Tcl callback to be activated at [cmd ttrace::enable].
Registered callbacks are activated on FIFO basis. The callback
definition includes the name of the callback, [arg cmd], a list
of callback arguments, [arg arglist] and the [arg body] of the
callback. Effectively, this actually resembles the call interface
of the standard Tcl [cmd proc] command.
[call [cmd ttrace::atdisable] [arg cmd] [arg arglist] [arg body]]
Registers Tcl callback to be activated at [cmd ttrace::disable].
Registered callbacks are activated on FIFO basis. The callback
definition includes the name of the callback, [arg cmd], a list
of callback arguments, [arg arglist] and the [arg body] of the
callback. Effectively, this actually resembles the call interface
of the standard Tcl [cmd proc] command.
[call [cmd ttrace::addtrace] [arg cmd] [arg arglist] [arg body]]
Registers Tcl callback to be activated for tracing the Tcl
[cmd cmd] command. The callback definition includes the name of
the Tcl command to trace, [arg cmd], a list of callback arguments,
[arg arglist] and the [arg body] of the callback. Effectively,
this actually resembles the call interface of the standard Tcl
[cmd proc] command.
[call [cmd ttrace::addscript] [arg name] [arg body]]
Registers Tcl callback to be activated for building a Tcl
script to be passed to other interpreters. This script is
used to set the stage for the Tcl [cmd unknown] command.
Registered callbacks are activated on FIFO basis.
The callback definition includes the name of the callback,
[arg name] and the [arg body] of the callback.
[call [cmd ttrace::addresolver] [arg cmd] [arg arglist] [arg body]]
Registers Tcl callback to be activated by the overloaded Tcl
[cmd unknown] command.
Registered callbacks are activated on FIFO basis.
This callback is used to resolve the resource and load the
resource in the current interpreter.
[call [cmd ttrace::addcleanup] [arg body]]
Registers Tcl callback to be activated by the [cmd trace::cleanup].
Registered callbacks are activated on FIFO basis.
[call [cmd ttrace::addentry] [arg cmd] [arg var] [arg val]]
Adds one entry to the named in-memory database.
[call [cmd ttrace::getentry] [arg cmd] [arg var]]
Returns the value of the entry from the named in-memory database.
[call [cmd ttrace::getentries] [arg cmd] [opt pattern]]
Returns names of all entries from the named in-memory database.
[call [cmd ttrace::delentry] [arg cmd]]
Deletes an entry from the named in-memory database.
[call [cmd ttrace::preload] [arg cmd]]
Registers the Tcl command to be loaded in the interpreter.
Commands registered this way will always be the part of
the interpreter and not be on-demand loaded by the Tcl
[cmd unknown] command.
[list_end]
[section DISCUSSION]
Common introspective state-replication approaches use a custom Tcl
script to introspect the running interpreter and synthesize another
Tcl script to replicate this state in some other interpreter.
This package, on the contrary, uses Tcl command traces. Command
traces are registered on selected Tcl commands, like [cmd proc],
[cmd namespace], [cmd load] and other standard (and/or user-defined)
Tcl commands. When activated, those traces build an in-memory
database of created resources. This database is used as a resource
repository for the (overloaded) Tcl [cmd unknown] command which
creates the requested resource in the interpreter on demand.
This way, users can update just one interpreter (master) in one
thread and replicate that interpreter state (or part of it) to other
threads/interpreters in the process.
[para]
Immediate benefit of such approach is the much smaller memory footprint
of the application and much faster thread creation. By not actually
loading all necessary procedures (and other resources) in every thread
at the thread initialization time, but by deferring this to the time the
resource is actually referenced, significant improvements in both
memory consumption and thread initialization time can be achieved. Some
tests have shown that memory footprint of an multithreading Tcl application
went down more than three times and thread startup time was reduced for
about 50 times. Note that your mileage may vary.
Other benefits include much finer control about what (and when) gets
replicated from the master to other Tcl thread/interpreters.
[see_also tsv tpool thread]
[keywords {command tracing} introspection]
[manpage_end]

400
pkgs/thread2.8.7/generic/psGdbm.c Normal file
View File

@@ -0,0 +1,400 @@
/*
* This file implements wrappers for persistent gdbm storage for the
* shared variable arrays.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* ----------------------------------------------------------------------------
*/
#ifdef HAVE_GDBM
#include "threadSvCmd.h"
#include <gdbm.h>
#include <stdlib.h> /* For free() */
/*
* Functions implementing the persistent store interface
*/
static ps_open_proc ps_gdbm_open;
static ps_close_proc ps_gdbm_close;
static ps_get_proc ps_gdbm_get;
static ps_put_proc ps_gdbm_put;
static ps_first_proc ps_gdbm_first;
static ps_next_proc ps_gdbm_next;
static ps_delete_proc ps_gdbm_delete;
static ps_free_proc ps_gdbm_free;
static ps_geterr_proc ps_gdbm_geterr;
/*
* This structure collects all the various pointers
* to the functions implementing the gdbm store.
*/
const PsStore GdbmStore = {
"gdbm",
NULL,
ps_gdbm_open,
ps_gdbm_get,
ps_gdbm_put,
ps_gdbm_first,
ps_gdbm_next,
ps_gdbm_delete,
ps_gdbm_close,
ps_gdbm_free,
ps_gdbm_geterr,
NULL
};
/*
*-----------------------------------------------------------------------------
*
* Sv_RegisterGdbmStore --
*
* Register the gdbm store with shared variable implementation.
*
* Results:
* None.
*
* Side effects:
* None.
*
*-----------------------------------------------------------------------------
*/
void
Sv_RegisterGdbmStore(void)
{
Sv_RegisterPsStore(&GdbmStore);
}
/*
*-----------------------------------------------------------------------------
*
* ps_gdbm_open --
*
* Opens the dbm-based persistent storage.
*
* Results:
* Opaque handle of the opened dbm storage.
*
* Side effects:
* The gdbm file might be created if not found.
*
*-----------------------------------------------------------------------------
*/
static ClientData
ps_gdbm_open(
const char *path)
{
GDBM_FILE dbf;
char *ext;
Tcl_DString toext;
Tcl_DStringInit(&toext);
ext = Tcl_UtfToExternalDString(NULL, path, strlen(path), &toext);
dbf = gdbm_open(ext, 512, GDBM_WRCREAT|GDBM_SYNC|GDBM_NOLOCK, 0666, NULL);
Tcl_DStringFree(&toext);
return dbf;
}
/*
*-----------------------------------------------------------------------------
*
* ps_gdbm_close --
*
* Closes the gdbm-based persistent storage.
*
* Results:
* 0 - ok
*
* Side effects:
* None.
*
*-----------------------------------------------------------------------------
*/
static int
ps_gdbm_close(
ClientData handle)
{
gdbm_close((GDBM_FILE)handle);
return 0;
}
/*
*-----------------------------------------------------------------------------
*
* ps_gdbm_get --
*
* Retrieves data for the key from the dbm storage.
*
* Results:
* 1 - no such key
* 0 - ok
*
* Side effects:
* Data returned must be freed by the caller.
*
*-----------------------------------------------------------------------------
*/
static int
ps_gdbm_get(
ClientData handle,
const char *key,
char **dataptrptr,
size_t *lenptr)
{
GDBM_FILE dbf = (GDBM_FILE)handle;
datum drec, dkey;
dkey.dptr = (char*)key;
dkey.dsize = strlen(key) + 1;
drec = gdbm_fetch(dbf, dkey);
if (drec.dptr == NULL) {
return 1;
}
*dataptrptr = drec.dptr;
*lenptr = drec.dsize;
return 0;
}
/*
*-----------------------------------------------------------------------------
*
* ps_gdbm_first --
*
* Starts the iterator over the dbm file and returns the first record.
*
* Results:
* 1 - no more records in the iterator
* 0 - ok
*
* Side effects:
* Data returned must be freed by the caller.
*
*-----------------------------------------------------------------------------
*/
static int
ps_gdbm_first(
ClientData handle,
char **keyptrptr,
char **dataptrptr,
size_t *lenptr)
{
GDBM_FILE dbf = (GDBM_FILE)handle;
datum drec, dkey;
dkey = gdbm_firstkey(dbf);
if (dkey.dptr == NULL) {
return 1;
}
drec = gdbm_fetch(dbf, dkey);
if (drec.dptr == NULL) {
return 1;
}
*dataptrptr = drec.dptr;
*lenptr = drec.dsize;
*keyptrptr = dkey.dptr;
return 0;
}
/*
*-----------------------------------------------------------------------------
*
* ps_gdbm_next --
*
* Uses the iterator over the dbm file and returns the next record.
*
* Results:
* 1 - no more records in the iterator
* 0 - ok
*
* Side effects:
* Data returned must be freed by the caller.
*
*-----------------------------------------------------------------------------
*/
static int ps_gdbm_next(
ClientData handle,
char **keyptrptr,
char **dataptrptr,
size_t *lenptr)
{
GDBM_FILE dbf = (GDBM_FILE)handle;
datum drec, dkey, dnext;
dkey.dptr = *keyptrptr;
dkey.dsize = strlen(*keyptrptr) + 1;
dnext = gdbm_nextkey(dbf, dkey);
free(*keyptrptr), *keyptrptr = NULL;
if (dnext.dptr == NULL) {
return 1;
}
drec = gdbm_fetch(dbf, dnext);
if (drec.dptr == NULL) {
return 1;
}
*dataptrptr = drec.dptr;
*lenptr = drec.dsize;
*keyptrptr = dnext.dptr;
return 0;
}
/*
*-----------------------------------------------------------------------------
*
* ps_gdbm_put --
*
* Stores used data bound to a key in dbm storage.
*
* Results:
* 0 - ok
* -1 - error; use ps_dbm_geterr to retrieve the error message
*
* Side effects:
* If the key is already associated with some user data, this will
* be replaced by the new data chunk.
*
*-----------------------------------------------------------------------------
*/
static int
ps_gdbm_put(
ClientData handle,
const char *key,
char *dataptr,
size_t len)
{
GDBM_FILE dbf = (GDBM_FILE)handle;
datum drec, dkey;
int ret;
dkey.dptr = (char*)key;
dkey.dsize = strlen(key) + 1;
drec.dptr = dataptr;
drec.dsize = len;
ret = gdbm_store(dbf, dkey, drec, GDBM_REPLACE);
if (ret == -1) {
return -1;
}
return 0;
}
/*
*-----------------------------------------------------------------------------
*
* ps_gdbm_delete --
*
* Deletes the key and associated data from the dbm storage.
*
* Results:
* 0 - ok
* -1 - error; use ps_dbm_geterr to retrieve the error message
*
* Side effects:
* If the key is already associated with some user data, this will
* be replaced by the new data chunk.
*
*-----------------------------------------------------------------------------
*/
static int
ps_gdbm_delete(
ClientData handle,
const char *key)
{
GDBM_FILE dbf = (GDBM_FILE)handle;
datum dkey;
int ret;
dkey.dptr = (char*)key;
dkey.dsize = strlen(key) + 1;
ret = gdbm_delete(dbf, dkey);
if (ret == -1) {
return -1;
}
return 0;
}
/*
*-----------------------------------------------------------------------------
*
* ps_gdbm_free --
*
* Frees memory allocated by the gdbm implementation.
*
* Results:
* None.
*
* Side effects:
* Memory gets reclaimed.
*
*-----------------------------------------------------------------------------
*/
static void
ps_gdbm_free(
ClientData handle,
void *data)
{
(void)handle;
free(data);
}
/*
*-----------------------------------------------------------------------------
*
* ps_gdbm_geterr --
*
* Retrieves the textual representation of the error caused
* by the last dbm command.
*
* Results:
* Pointer to the strimg message.
*
* Side effects:
* None.
*
*-----------------------------------------------------------------------------
*/
static const char*
ps_gdbm_geterr(
ClientData handle)
{
(void)handle;
/*
* The problem with gdbm interface is that it uses the global
* gdbm_errno variable which is not per-thread nor mutex
* protected. This variable is used to reference array of gdbm
* error text strings. It is very dangerous to use this in the
* MT-program without proper locking. For this kind of app
* we should not be concerned with that, since all ps_gdbm_xxx
* operations are performed under shared variable lock anyway.
*/
return gdbm_strerror(gdbm_errno);
}
#endif /* HAVE_GDBM */
/* EOF $RCSfile*/
/* Emacs Setup Variables */
/* Local Variables: */
/* mode: C */
/* indent-tabs-mode: nil */
/* c-basic-offset: 4 */
/* End: */

24
pkgs/thread2.8.7/generic/psGdbm.h Normal file
View File

@@ -0,0 +1,24 @@
/*
* psGdbm.h --
*
* See the file "license.txt" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* ---------------------------------------------------------------------------
*/
#ifndef _PSGDBM_H_
#define _PSGDBM_H_
void Sv_RegisterGdbmStore();
#endif /* _PSGDBM_H_ */
/* EOF $RCSfile */
/* Emacs Setup Variables */
/* Local Variables: */
/* mode: C */
/* indent-tabs-mode: nil */
/* c-basic-offset: 4 */
/* End: */

545
pkgs/thread2.8.7/generic/psLmdb.c Normal file
View File

@@ -0,0 +1,545 @@
/*
* This file implements wrappers for persistent lmdb storage for the
* shared variable arrays.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* ----------------------------------------------------------------------------
*/
#ifdef HAVE_LMDB
#include "threadSvCmd.h"
#include <lmdb.h>
/*
* Structure keeping the lmdb environment context
*/
typedef struct {
MDB_env * env; // Environment
MDB_txn * txn; // Last active read transaction
MDB_cursor * cur; // Cursor used for ps_lmdb_first and ps_lmdb_next
MDB_dbi dbi; // Open database (default db)
int err; // Last error (used in ps_lmdb_geterr)
} * LmdbCtx;
/*
* Transaction and DB open mode
*/
enum LmdbOpenMode { LmdbRead, LmdbWrite };
// Initialize or renew a transaction.
static void LmdbTxnGet(LmdbCtx ctx, enum LmdbOpenMode mode);
// Commit a transaction.
static void LmdbTxnCommit(LmdbCtx ctx);
// Abort a transaction
static void LmdbTxnAbort(LmdbCtx ctx);
void LmdbTxnGet(LmdbCtx ctx, enum LmdbOpenMode mode)
{
// Read transactions are reused, if possible
if (ctx->txn && mode == LmdbRead)
{
ctx->err = mdb_txn_renew(ctx->txn);
if (ctx->err)
{
ctx->txn = NULL;
}
}
else if (ctx->txn && mode == LmdbWrite)
{
LmdbTxnAbort(ctx);
}
if (ctx->txn == NULL)
{
ctx->err = mdb_txn_begin(ctx->env, NULL, 0, &ctx->txn);
}
if (ctx->err)
{
ctx->txn = NULL;
return;
}
// Given the setup above, and the arguments given, this won't fail.
mdb_dbi_open(ctx->txn, NULL, 0, &ctx->dbi);
}
void LmdbTxnCommit(LmdbCtx ctx)
{
ctx->err = mdb_txn_commit(ctx->txn);
ctx->txn = NULL;
}
void LmdbTxnAbort(LmdbCtx ctx)
{
mdb_txn_abort(ctx->txn);
ctx->txn = NULL;
}
/*
* Functions implementing the persistent store interface
*/
static ps_open_proc ps_lmdb_open;
static ps_close_proc ps_lmdb_close;
static ps_get_proc ps_lmdb_get;
static ps_put_proc ps_lmdb_put;
static ps_first_proc ps_lmdb_first;
static ps_next_proc ps_lmdb_next;
static ps_delete_proc ps_lmdb_delete;
static ps_free_proc ps_lmdb_free;
static ps_geterr_proc ps_lmdb_geterr;
/*
* This structure collects all the various pointers
* to the functions implementing the lmdb store.
*/
const PsStore LmdbStore = {
"lmdb",
NULL,
ps_lmdb_open,
ps_lmdb_get,
ps_lmdb_put,
ps_lmdb_first,
ps_lmdb_next,
ps_lmdb_delete,
ps_lmdb_close,
ps_lmdb_free,
ps_lmdb_geterr,
NULL
};
/*
*-----------------------------------------------------------------------------
*
* Sv_RegisterLmdbStore --
*
* Register the lmdb store with shared variable implementation.
*
* Results:
* None.
*
* Side effects:
* None.
*
*-----------------------------------------------------------------------------
*/
void
Sv_RegisterLmdbStore(void)
{
Sv_RegisterPsStore(&LmdbStore);
}
/*
*-----------------------------------------------------------------------------
*
* ps_lmdb_open --
*
* Opens the lmdb-based persistent storage.
*
* Results:
* Opaque handle for LmdbCtx.
*
* Side effects:
* The lmdb file might be created if not found.
*
*-----------------------------------------------------------------------------
*/
static ClientData
ps_lmdb_open(
const char *path)
{
LmdbCtx ctx;
char *ext;
Tcl_DString toext;
ctx = (LmdbCtx)ckalloc(sizeof(*ctx));
if (ctx == NULL)
{
return NULL;
}
ctx->env = NULL;
ctx->txn = NULL;
ctx->cur = NULL;
ctx->dbi = 0;
ctx->err = mdb_env_create(&ctx->env);
if (ctx->err)
{
ckfree(ctx);
return NULL;
}
Tcl_DStringInit(&toext);
ext = Tcl_UtfToExternalDString(NULL, path, strlen(path), &toext);
ctx->err = mdb_env_open(ctx->env, ext, MDB_NOSUBDIR|MDB_NOLOCK, 0666);
Tcl_DStringFree(&toext);
if (ctx->err)
{
ckfree(ctx);
return NULL;
}
return ctx;
}
/*
*-----------------------------------------------------------------------------
*
* ps_lmdb_close --
*
* Closes the lmdb-based persistent storage.
*
* Results:
* 0 - ok
*
* Side effects:
* None.
*
*-----------------------------------------------------------------------------
*/
static int
ps_lmdb_close(
ClientData handle)
{
LmdbCtx ctx = (LmdbCtx)handle;
if (ctx->cur)
{
mdb_cursor_close(ctx->cur);
}
if (ctx->txn)
{
LmdbTxnAbort(ctx);
}
mdb_env_close(ctx->env);
ckfree(ctx);
return 0;
}
/*
*-----------------------------------------------------------------------------
*
* ps_lmdb_get --
*
* Retrieves data for the key from the lmdb storage.
*
* Results:
* 1 - no such key
* 0 - ok
*
* Side effects:
* Data returned must be copied, then psFree must be called.
*
*-----------------------------------------------------------------------------
*/
static int
ps_lmdb_get(
ClientData handle,
const char *keyptr,
char **dataptrptr,
size_t *lenptr)
{
LmdbCtx ctx = (LmdbCtx)handle;
MDB_val key, data;
LmdbTxnGet(ctx, LmdbRead);
if (ctx->err)
{
return 1;
}
key.mv_data = (void *)keyptr;
key.mv_size = strlen(keyptr) + 1;
ctx->err = mdb_get(ctx->txn, ctx->dbi, &key, &data);
if (ctx->err)
{
mdb_txn_reset(ctx->txn);
return 1;
}
*dataptrptr = (char *)data.mv_data;
*lenptr = data.mv_size;
/*
* Transaction is left open at this point, so that the caller can get ahold
* of the data and make a copy of it. Afterwards, it will call ps_lmdb_free
* to free the data, and we'll catch the chance to reset the transaction
* there.
*/
return 0;
}
/*
*-----------------------------------------------------------------------------
*
* ps_lmdb_first --
*
* Starts the iterator over the lmdb file and returns the first record.
*
* Results:
* 1 - no more records in the iterator
* 0 - ok
*
* Side effects:
* Data returned must be copied, then psFree must be called.
*
*-----------------------------------------------------------------------------
*/
static int
ps_lmdb_first(
ClientData handle,
char **keyptrptr,
char **dataptrptr,
size_t *lenptr)
{
LmdbCtx ctx = (LmdbCtx)handle;
MDB_val key, data;
LmdbTxnGet(ctx, LmdbRead);
if (ctx->err)
{
return 1;
}
ctx->err = mdb_cursor_open(ctx->txn, ctx->dbi, &ctx->cur);
if (ctx->err)
{
return 1;
}
ctx->err = mdb_cursor_get(ctx->cur, &key, &data, MDB_FIRST);
if (ctx->err)
{
mdb_txn_reset(ctx->txn);
mdb_cursor_close(ctx->cur);
ctx->cur = NULL;
return 1;
}
*dataptrptr = (char *)data.mv_data;
*lenptr = data.mv_size;
*keyptrptr = (char *)key.mv_data;
return 0;
}
/*
*-----------------------------------------------------------------------------
*
* ps_lmdb_next --
*
* Uses the iterator over the lmdb file and returns the next record.
*
* Results:
* 1 - no more records in the iterator
* 0 - ok
*
* Side effects:
* Data returned must be copied, then psFree must be called.
*
*-----------------------------------------------------------------------------
*/
static int ps_lmdb_next(
ClientData handle,
char **keyptrptr,
char **dataptrptr,
size_t *lenptr)
{
LmdbCtx ctx = (LmdbCtx)handle;
MDB_val key, data;
ctx->err = mdb_cursor_get(ctx->cur, &key, &data, MDB_NEXT);
if (ctx->err)
{
mdb_txn_reset(ctx->txn);
mdb_cursor_close(ctx->cur);
ctx->cur = NULL;
return 1;
}
*dataptrptr = (char *)data.mv_data;
*lenptr = data.mv_size;
*keyptrptr = (char *)key.mv_data;
return 0;
}
/*
*-----------------------------------------------------------------------------
*
* ps_lmdb_put --
*
* Stores used data bound to a key in lmdb storage.
*
* Results:
* 0 - ok
* -1 - error; use ps_lmdb_geterr to retrieve the error message
*
* Side effects:
* If the key is already associated with some user data, this will
* be replaced by the new data chunk.
*
*-----------------------------------------------------------------------------
*/
static int
ps_lmdb_put(
ClientData handle,
const char *keyptr,
char *dataptr,
size_t len)
{
LmdbCtx ctx = (LmdbCtx)handle;
MDB_val key, data;
LmdbTxnGet(ctx, LmdbWrite);
if (ctx->err)
{
return -1;
}
key.mv_data = (void*)keyptr;
key.mv_size = strlen(keyptr) + 1;
data.mv_data = dataptr;
data.mv_size = len;
ctx->err = mdb_put(ctx->txn, ctx->dbi, &key, &data, 0);
if (ctx->err)
{
LmdbTxnAbort(ctx);
}
else
{
LmdbTxnCommit(ctx);
}
return ctx->err ? -1 : 0;
}
/*
*-----------------------------------------------------------------------------
*
* ps_lmdb_delete --
*
* Deletes the key and associated data from the lmdb storage.
*
* Results:
* 0 - ok
* -1 - error; use ps_lmdb_geterr to retrieve the error message
*
* Side effects:
* If the key is already associated with some user data, this will
* be replaced by the new data chunk.
*
*-----------------------------------------------------------------------------
*/
static int
ps_lmdb_delete(
ClientData handle,
const char *keyptr)
{
LmdbCtx ctx = (LmdbCtx)handle;
MDB_val key;
LmdbTxnGet(ctx, LmdbWrite);
if (ctx->err)
{
return -1;
}
key.mv_data = (void*)keyptr;
key.mv_size = strlen(keyptr) + 1;
ctx->err = mdb_del(ctx->txn, ctx->dbi, &key, NULL);
if (ctx->err)
{
LmdbTxnAbort(ctx);
}
else
{
LmdbTxnCommit(ctx);
}
ctx->txn = NULL;
return ctx->err ? -1 : 0;
}
/*
*-----------------------------------------------------------------------------
*
* ps_lmdb_free --
*
* This function is called to free data returned by the persistent store
* after calls to psFirst, psNext, or psGet. Lmdb doesn't need to free any
* data, as the data returned is owned by lmdb. On the other hand, this
* method is required to reset the read transaction. This is done only
* when iteration is over (ctx->cur == NULL).
*
* Results:
* None.
*
* Side effects:
* Memory gets reclaimed.
*
*-----------------------------------------------------------------------------
*/
static void
ps_lmdb_free(
ClientData handle,
void *data)
{
LmdbCtx ctx = (LmdbCtx)handle;
(void)data;
if (ctx->cur == NULL)
{
mdb_txn_reset(ctx->txn);
}
}
/*
*-----------------------------------------------------------------------------
*
* ps_lmdb_geterr --
*
* Retrieves the textual representation of the error caused
* by the last lmdb command.
*
* Results:
* Pointer to the string message.
*
* Side effects:
* None.
*
*-----------------------------------------------------------------------------
*/
static const char*
ps_lmdb_geterr(
ClientData handle)
{
LmdbCtx ctx = (LmdbCtx)handle;
return mdb_strerror(ctx->err);
}
#endif /* HAVE_LMDB */
/* EOF $RCSfile*/
/* Emacs Setup Variables */
/* Local Variables: */
/* mode: C */
/* indent-tabs-mode: nil */
/* c-basic-offset: 4 */
/* End: */

24
pkgs/thread2.8.7/generic/psLmdb.h Normal file
View File

@@ -0,0 +1,24 @@
/*
* psLmdb.h --
*
* See the file "license.txt" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* ---------------------------------------------------------------------------
*/
#ifndef _PSLMDB_H_
#define _PSLMDB_H_
void Sv_RegisterLmdbStore();
#endif /* _PSLMDB_H_ */
/* EOF $RCSfile */
/* Emacs Setup Variables */
/* Local Variables: */
/* mode: C */
/* indent-tabs-mode: nil */
/* c-basic-offset: 4 */
/* End: */

36
pkgs/thread2.8.7/generic/tclThread.h Normal file
View File

@@ -0,0 +1,36 @@
/*
* --------------------------------------------------------------------------
* tclthread.h --
*
* Global header file for the thread extension.
*
* Copyright (c) 2002 ActiveState Corporation.
* Copyright (c) 2002 by Zoran Vasiljevic.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* ---------------------------------------------------------------------------
*/
/*
* Thread extension version numbers are not stored here
* because this isn't a public export file.
*/
#ifndef _TCL_THREAD_H_
#define _TCL_THREAD_H_
#include <tcl.h>
/*
* Exported from threadCmd.c file.
*/
#ifdef __cplusplus
extern "C" {
#endif
DLLEXPORT int Thread_Init(Tcl_Interp *interp);
#ifdef __cplusplus
}
#endif
#endif /* _TCL_THREAD_H_ */

193
pkgs/thread2.8.7/generic/tclThreadInt.h Normal file
View File

@@ -0,0 +1,193 @@
/*
* --------------------------------------------------------------------------
* tclthreadInt.h --
*
* Global internal header file for the thread extension.
*
* Copyright (c) 2002 ActiveState Corporation.
* Copyright (c) 2002 by Zoran Vasiljevic.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* ---------------------------------------------------------------------------
*/
#ifndef _TCL_THREAD_INT_H_
#define _TCL_THREAD_INT_H_
#include "tclThread.h"
#include <stdlib.h> /* For strtoul */
#include <string.h> /* For memset and friends */
/*
* MSVC 8.0 started to mark many standard C library functions depreciated
* including the *printf family and others. Tell it to shut up.
* (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0)
*/
#if defined(_MSC_VER)
# pragma warning(disable:4244)
# if _MSC_VER >= 1400
# pragma warning(disable:4267)
# pragma warning(disable:4996)
# endif
#endif
/*
* Used to tag functions that are only to be visible within the module being
* built and not outside it (where this is supported by the linker).
*/
#ifndef MODULE_SCOPE
# ifdef __cplusplus
# define MODULE_SCOPE extern "C"
# else
# define MODULE_SCOPE extern
# endif
#endif
/*
* For linking against NaviServer/AOLserver require V4 at least
*/
#ifdef NS_AOLSERVER
# include <ns.h>
# if !defined(NS_MAJOR_VERSION) || NS_MAJOR_VERSION < 4
# error "unsupported NaviServer/AOLserver version"
# endif
#endif
/*
* Allow for some command names customization.
* Only thread:: and tpool:: are handled here.
* Shared variable commands are more complicated.
* Look into the threadSvCmd.h for more info.
*/
#define THREAD_CMD_PREFIX "thread::"
#define TPOOL_CMD_PREFIX "tpool::"
/*
* Exported from threadSvCmd.c file.
*/
MODULE_SCOPE const char *SvInit(Tcl_Interp *interp);
/*
* Exported from threadSpCmd.c file.
*/
MODULE_SCOPE const char *SpInit(Tcl_Interp *interp);
/*
* Exported from threadPoolCmd.c file.
*/
MODULE_SCOPE const char *TpoolInit(Tcl_Interp *interp);
/*
* Macros for splicing in/out of linked lists
*/
#define SpliceIn(a,b) \
(a)->nextPtr = (b); \
if ((b) != NULL) \
(b)->prevPtr = (a); \
(a)->prevPtr = NULL, (b) = (a)
#define SpliceOut(a,b) \
if ((a)->prevPtr != NULL) \
(a)->prevPtr->nextPtr = (a)->nextPtr; \
else \
(b) = (a)->nextPtr; \
if ((a)->nextPtr != NULL) \
(a)->nextPtr->prevPtr = (a)->prevPtr
/*
* Version macros
*/
#define TCL_MINIMUM_VERSION(major,minor) \
((TCL_MAJOR_VERSION > (major)) || \
((TCL_MAJOR_VERSION == (major)) && (TCL_MINOR_VERSION >= (minor))))
/*
* Utility macros
*/
#define TCL_CMD(a,b,c) \
if (Tcl_CreateObjCommand((a),(b),(c),NULL, NULL) == NULL) \
return NULL;
#define OPT_CMP(a,b) \
((a) && (b) && ((a)[0]==(b)[0]) && ((a)[1]==(b)[1]) && (!strcmp((a),(b))))
#ifndef TCL_TSD_INIT
#define TCL_TSD_INIT(keyPtr) \
(ThreadSpecificData*)Tcl_GetThreadData((keyPtr),sizeof(ThreadSpecificData))
#endif
/*
* Structure to pass to NsThread_Init. This holds the module
* and virtual server name for proper interp initializations.
*/
typedef struct {
char *modname;
char *server;
} NsThreadInterpData;
/*
* Handle binary compatibility regarding
* Tcl_GetErrorLine in 8.x
* See Tcl bug #3562640.
*/
MODULE_SCOPE int threadTclVersion;
typedef struct {
void *unused1;
void *unused2;
int errorLine;
} tclInterpType;
#if defined(TCL_TIP285) && defined(USE_TCL_STUBS)
# undef Tcl_GetErrorLine
# define Tcl_GetErrorLine(interp) ((threadTclVersion>85)? \
((int (*)(Tcl_Interp *))(void *)((&(tclStubsPtr->tcl_PkgProvideEx))[605]))(interp): \
(((tclInterpType *)(interp))->errorLine))
/* TIP #270 */
# undef Tcl_AddErrorInfo
# define Tcl_AddErrorInfo(interp, msg) ((threadTclVersion>85)? \
((void (*)(Tcl_Interp *, Tcl_Obj *))(void *)((&(tclStubsPtr->tcl_PkgProvideEx))[574]))(interp, Tcl_NewStringObj(msg, -1)): \
((void (*)(Tcl_Interp *, const char *))(void *)((&(tclStubsPtr->tcl_PkgProvideEx))[66]))(interp, msg))
/* TIP #337 */
# undef Tcl_BackgroundException
# define Tcl_BackgroundException(interp, result) ((threadTclVersion>85)? \
((void (*)(Tcl_Interp *, int))(void *)((&(tclStubsPtr->tcl_PkgProvideEx))[609]))(interp, result): \
((void (*)(Tcl_Interp *))(void *)((&(tclStubsPtr->tcl_PkgProvideEx))[76]))(interp))
#elif !TCL_MINIMUM_VERSION(8,6)
/* 8.5, 8.4, or less - Emulate access to the error-line information */
# define Tcl_GetErrorLine(interp) (((tclInterpType *)(interp))->errorLine)
#endif
/* When running on Tcl >= 8.7, make sure that Thread still runs when Tcl is compiled
* with -DTCL_NO_DEPRECATED=1. Stub entries for Tcl_SetIntObj/Tcl_NewIntObj are NULL then.
* Just use Tcl_SetWideIntObj/Tcl_NewWideIntObj in stead. We don't simply want to use
* Tcl_SetWideIntObj/Tcl_NewWideIntObj always, since extensions might not expect to
* get an actual "wideInt".
*/
#if defined(USE_TCL_STUBS)
# undef Tcl_SetIntObj
# define Tcl_SetIntObj(objPtr, value) ((threadTclVersion>86)? \
((void (*)(Tcl_Obj *, Tcl_WideInt))(void *)((&(tclStubsPtr->tcl_PkgProvideEx))[489]))(objPtr, (int)(value)): \
((void (*)(Tcl_Obj *, int))(void *)((&(tclStubsPtr->tcl_PkgProvideEx))[61]))(objPtr, value))
# undef Tcl_NewIntObj
# define Tcl_NewIntObj(value) ((threadTclVersion>86)? \
((Tcl_Obj * (*)(Tcl_WideInt))(void *)((&(tclStubsPtr->tcl_PkgProvideEx))[488]))((int)(value)): \
((Tcl_Obj * (*)(int))(void *)((&(tclStubsPtr->tcl_PkgProvideEx))[52]))(value))
# undef Tcl_GetUnicodeFromObj
# define Tcl_GetUnicodeFromObj ((((&(tclStubsPtr->tcl_PkgProvideEx))[378]) != ((&(tclStubsPtr->tcl_PkgProvideEx))[434])) ? \
((void (*)(Tcl_Obj *, int *))(void *)((&(tclStubsPtr->tcl_PkgProvideEx))[434])) : ((void (*)(Tcl_Obj *, int *)) NULL))
#endif
#endif /* _TCL_THREAD_INT_H_ */

1486
pkgs/thread2.8.7/generic/tclXkeylist.c Normal file
View File

File diff suppressed because it is too large Load Diff

63
pkgs/thread2.8.7/generic/tclXkeylist.h Normal file
View File

@@ -0,0 +1,63 @@
/*
* tclXkeylist.h --
*
* Extended Tcl keyed list commands and interfaces.
*-----------------------------------------------------------------------------
* Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans.
*
* Permission to use, copy, modify, and distribute this software and its
* documentation for any purpose and without fee is hereby granted, provided
* that the above copyright notice appear in all copies. Karl Lehenbauer and
* Mark Diekhans make no representations about the suitability of this
* software for any purpose. It is provided "as is" without express or
* implied warranty.
*-----------------------------------------------------------------------------
*/
#ifndef _KEYLIST_H_
#define _KEYLIST_H_
#include "tclThreadInt.h"
/*
* Keyed list object interface commands
*/
MODULE_SCOPE Tcl_Obj* TclX_NewKeyedListObj();
MODULE_SCOPE void TclX_KeyedListInit(Tcl_Interp*);
MODULE_SCOPE int TclX_KeyedListGet(Tcl_Interp*, Tcl_Obj*, const char*, Tcl_Obj**);
MODULE_SCOPE int TclX_KeyedListSet(Tcl_Interp*, Tcl_Obj*, const char*, Tcl_Obj*);
MODULE_SCOPE int TclX_KeyedListDelete(Tcl_Interp*, Tcl_Obj*, const char*);
MODULE_SCOPE int TclX_KeyedListGetKeys(Tcl_Interp*, Tcl_Obj*, const char*, Tcl_Obj**);
/*
* This is defined in keylist.c. We need it here
* to be able to plug-in our custom keyed-list
* object duplicator which produces proper deep
* copies of the keyed-list objects. The standard
* one produces shallow copies which are not good
* for usage in the thread shared variables code.
*/
MODULE_SCOPE Tcl_ObjType keyedListType;
/*
* Exported for usage in Sv_DuplicateObj. This is slightly
* modified version of the DupKeyedListInternalRep() function.
* It does a proper deep-copy of the keyed list object.
*/
MODULE_SCOPE void DupKeyedListInternalRepShared(Tcl_Obj*, Tcl_Obj*);
#endif /* _KEYLIST_H_ */
/* EOF $RCSfile: tclXkeylist.h,v $ */
/* Emacs Setup Variables */
/* Local Variables: */
/* mode: C */
/* indent-tabs-mode: nil */
/* c-basic-offset: 4 */
/* End: */

3942
pkgs/thread2.8.7/generic/threadCmd.c Normal file
View File

File diff suppressed because it is too large Load Diff

88
pkgs/thread2.8.7/generic/threadNs.c Normal file
View File

@@ -0,0 +1,88 @@
/*
* threadNs.c --
*
* Adds interface for loading the extension into the NaviServer/AOLserver.
*
* Copyright (c) 2002 by Zoran Vasiljevic.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* ---------------------------------------------------------------------------
*/
#ifdef NS_AOLSERVER
#include <ns.h>
#include "tclThreadInt.h"
int Ns_ModuleVersion = 1;
/*
*----------------------------------------------------------------------------
*
* NsThread_Init --
*
* Loads the package for the first time, i.e. in the startup thread.
*
* Results:
* Standard Tcl result
*
* Side effects:
* Package initialized. Tcl commands created.
*
*----------------------------------------------------------------------------
*/
static int
NsThread_Init (Tcl_Interp *interp, void *cd)
{
NsThreadInterpData *md = (NsThreadInterpData*)cd;
int ret = Thread_Init(interp);
if (ret != TCL_OK) {
Ns_Log(Warning, "can't load module %s: %s", md->modname,
Tcl_GetString(Tcl_GetObjResult(interp)));
return TCL_ERROR;
}
Tcl_SetAssocData(interp, "thread:nsd", NULL, md);
return TCL_OK;
}
/*
*----------------------------------------------------------------------------
*
* Ns_ModuleInit --
*
* Called by the NaviServer/AOLserver when loading shared object file.
*
* Results:
* Standard NaviServer/AOLserver result
*
* Side effects:
* Many. Depends on the package.
*
*----------------------------------------------------------------------------
*/
int
Ns_ModuleInit(char *srv, char *mod)
{
NsThreadInterpData *md = NULL;
md = (NsThreadInterpData*)ns_malloc(sizeof(NsThreadInterpData));
md->modname = strcpy(ns_malloc(strlen(mod)+1), mod);
md->server = strcpy(ns_malloc(strlen(srv)+1), srv);
return Ns_TclRegisterTrace(srv, NsThread_Init, (void*)md, NS_TCL_TRACE_CREATE);
}
#endif /* NS_AOLSERVER */
/* EOF $RCSfile: aolstub.cpp,v $ */
/* Emacs Setup Variables */
/* Local Variables: */
/* mode: C */
/* indent-tabs-mode: nil */
/* c-basic-offset: 4 */
/* End: */

1964
pkgs/thread2.8.7/generic/threadPoolCmd.c Normal file
View File

File diff suppressed because it is too large Load Diff

1934
pkgs/thread2.8.7/generic/threadSpCmd.c Normal file
View File

File diff suppressed because it is too large Load Diff

128
pkgs/thread2.8.7/generic/threadSpCmd.h Normal file
View File

@@ -0,0 +1,128 @@
/*
* This is the header file for the module that implements some missing
* synchronization primitives from the Tcl API.
*
* Copyright (c) 2002 by Zoran Vasiljevic.
*
* See the file "license.txt" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* ---------------------------------------------------------------------------
*/
#ifndef _SP_H_
#define _SP_H_
#include "tclThreadInt.h"
/*
* The following structure defines a locking bucket. A locking
* bucket is associated with a mutex and protects access to
* objects stored in bucket hash table.
*/
typedef struct SpBucket {
Tcl_Mutex lock; /* For locking the bucket */
Tcl_Condition cond; /* For waiting on threads to release items */
Tcl_HashTable handles; /* Hash table of given-out handles in bucket */
} SpBucket;
#define NUMSPBUCKETS 32
/*
* All types of mutexes share this common part.
*/
typedef struct Sp_AnyMutex_ {
int lockcount; /* If !=0 mutex is locked */
int numlocks; /* Number of times the mutex got locked */
Tcl_Mutex lock; /* Regular mutex */
Tcl_ThreadId owner; /* Current lock owner thread (-1 = any) */
} Sp_AnyMutex;
/*
* Implementation of the exclusive mutex.
*/
typedef struct Sp_ExclusiveMutex_ {
int lockcount; /* Flag: 1-locked, 0-not locked */
int numlocks; /* Number of times the mutex got locked */
Tcl_Mutex lock; /* Regular mutex */
Tcl_ThreadId owner; /* Current lock owner thread */
/* --- */
Tcl_Mutex mutex; /* Mutex being locked */
} Sp_ExclusiveMutex_;
typedef Sp_ExclusiveMutex_* Sp_ExclusiveMutex;
/*
* Implementation of the recursive mutex.
*/
typedef struct Sp_RecursiveMutex_ {
int lockcount; /* # of times this mutex is locked */
int numlocks; /* Number of time the mutex got locked */
Tcl_Mutex lock; /* Regular mutex */
Tcl_ThreadId owner; /* Current lock owner thread */
/* --- */
Tcl_Condition cond; /* Wait to be allowed to lock the mutex */
} Sp_RecursiveMutex_;
typedef Sp_RecursiveMutex_* Sp_RecursiveMutex;
/*
* Implementation of the read/writer mutex.
*/
typedef struct Sp_ReadWriteMutex_ {
int lockcount; /* >0: # of readers, -1: sole writer */
int numlocks; /* Number of time the mutex got locked */
Tcl_Mutex lock; /* Regular mutex */
Tcl_ThreadId owner; /* Current lock owner thread */
/* --- */
unsigned int numrd; /* # of readers waiting for lock */
unsigned int numwr; /* # of writers waiting for lock */
Tcl_Condition rcond; /* Reader lockers wait here */
Tcl_Condition wcond; /* Writer lockers wait here */
} Sp_ReadWriteMutex_;
typedef Sp_ReadWriteMutex_* Sp_ReadWriteMutex;
/*
* API for exclusive mutexes.
*/
MODULE_SCOPE int Sp_ExclusiveMutexLock(Sp_ExclusiveMutex *mutexPtr);
MODULE_SCOPE int Sp_ExclusiveMutexIsLocked(Sp_ExclusiveMutex *mutexPtr);
MODULE_SCOPE int Sp_ExclusiveMutexUnlock(Sp_ExclusiveMutex *mutexPtr);
MODULE_SCOPE void Sp_ExclusiveMutexFinalize(Sp_ExclusiveMutex *mutexPtr);
/*
* API for recursive mutexes.
*/
MODULE_SCOPE int Sp_RecursiveMutexLock(Sp_RecursiveMutex *mutexPtr);
MODULE_SCOPE int Sp_RecursiveMutexIsLocked(Sp_RecursiveMutex *mutexPtr);
MODULE_SCOPE int Sp_RecursiveMutexUnlock(Sp_RecursiveMutex *mutexPtr);
MODULE_SCOPE void Sp_RecursiveMutexFinalize(Sp_RecursiveMutex *mutexPtr);
/*
* API for reader/writer mutexes.
*/
MODULE_SCOPE int Sp_ReadWriteMutexRLock(Sp_ReadWriteMutex *mutexPtr);
MODULE_SCOPE int Sp_ReadWriteMutexWLock(Sp_ReadWriteMutex *mutexPtr);
MODULE_SCOPE int Sp_ReadWriteMutexIsLocked(Sp_ReadWriteMutex *mutexPtr);
MODULE_SCOPE int Sp_ReadWriteMutexUnlock(Sp_ReadWriteMutex *mutexPtr);
MODULE_SCOPE void Sp_ReadWriteMutexFinalize(Sp_ReadWriteMutex *mutexPtr);
#endif /* _SP_H_ */
/* EOF $RCSfile: threadSpCmd.h,v $ */
/* Emacs Setup Variables */
/* Local Variables: */
/* mode: C */
/* indent-tabs-mode: nil */
/* c-basic-offset: 4 */
/* End: */

2446
pkgs/thread2.8.7/generic/threadSvCmd.c Normal file
View File

File diff suppressed because it is too large Load Diff

225
pkgs/thread2.8.7/generic/threadSvCmd.h Normal file
View File

@@ -0,0 +1,225 @@
/*
* This is the header file for the module that implements shared variables.
* for protected multithreaded access.
*
* Copyright (c) 2002 by Zoran Vasiljevic.
*
* See the file "license.txt" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* ---------------------------------------------------------------------------
*/
#ifndef _SV_H_
#define _SV_H_
#include <tcl.h>
#include <ctype.h>
#include <string.h>
#include "threadSpCmd.h" /* For recursive locks */
/*
* Uncomment following line to get command-line
* compatibility with AOLserver nsv_* commands
*/
/* #define NSV_COMPAT 1 */
/*
* Uncomment following line to force command-line
* compatibility with older thread::sv_ commands.
*/
/* #define OLD_COMPAT 1 */
#ifdef NSV_COMPAT
# define TSV_CMD2_PREFIX "nsv_" /* Compatiblity prefix for NaviServer/AOLserver */
#else
# define TSV_CMD2_PREFIX "sv_" /* Regular command prefix for NaviServer/AOLserver */
#endif
#ifdef OLD_COMPAT
# define TSV_CMD_PREFIX "thread::sv_" /* Old command prefix for Tcl */
#else
# define TSV_CMD_PREFIX "tsv::" /* Regular command prefix for Tcl */
#endif
/*
* Used when creating arrays/variables
*/
#define FLAGS_CREATEARRAY 1 /* Create the array in bucket if none found */
#define FLAGS_NOERRMSG 2 /* Do not format error message */
#define FLAGS_CREATEVAR 4 /* Create the array variable if none found */
/*
* Macros for handling locking and unlocking
*/
#define LOCK_BUCKET(a) Sp_RecursiveMutexLock(&(a)->lock)
#define UNLOCK_BUCKET(a) Sp_RecursiveMutexUnlock(&(a)->lock)
#define LOCK_CONTAINER(a) Sp_RecursiveMutexLock(&(a)->bucketPtr->lock)
#define UNLOCK_CONTAINER(a) Sp_RecursiveMutexUnlock(&(a)->bucketPtr->lock)
/*
* This is named synetrically to LockArray as function
* rather than as a macro just to improve readability.
*/
#define UnlockArray(a) UNLOCK_CONTAINER(a)
/*
* Mode for Sv_PutContainer, so it knows what
* happened with the embedded shared object.
*/
#define SV_UNCHANGED 0 /* Object has not been modified */
#define SV_CHANGED 1 /* Object has been modified */
#define SV_ERROR -1 /* Object may be in incosistent state */
/*
* Definitions of functions implementing simple key/value
* persistent storage for shared variable arrays.
*/
typedef ClientData (ps_open_proc)(const char*);
typedef int (ps_get_proc) (ClientData, const char*, char**, size_t*);
typedef int (ps_put_proc) (ClientData, const char*, char*, size_t);
typedef int (ps_first_proc) (ClientData, char**, char**, size_t*);
typedef int (ps_next_proc) (ClientData, char**, char**, size_t*);
typedef int (ps_delete_proc)(ClientData, const char*);
typedef int (ps_close_proc) (ClientData);
typedef void(ps_free_proc) (ClientData, void*);
typedef const char* (ps_geterr_proc)(ClientData);
/*
* This structure maintains a bunch of pointers to functions implementing
* the simple persistence layer for the shared variable arrays.
*/
typedef struct PsStore {
const char *type; /* Type identifier of the persistent storage */
ClientData psHandle; /* Handle to the opened storage */
ps_open_proc *psOpen; /* Function to open the persistent key store */
ps_get_proc *psGet; /* Function to retrieve value bound to key */
ps_put_proc *psPut; /* Function to store user key and value */
ps_first_proc *psFirst; /* Function to retrieve the first key/value */
ps_next_proc *psNext; /* Function to retrieve the next key/value */
ps_delete_proc *psDelete; /* Function to delete user key and value */
ps_close_proc *psClose; /* Function to close the persistent store */
ps_free_proc *psFree; /* Fuction to free allocated memory */
ps_geterr_proc *psError; /* Function to return last store error */
struct PsStore *nextPtr; /* For linking into linked lists */
} PsStore;
/*
* The following structure defines a collection of arrays.
* Only the arrays within a given bucket share a lock,
* allowing for more concurency.
*/
typedef struct Bucket {
Sp_RecursiveMutex lock; /* */
Tcl_HashTable arrays; /* Hash table of all arrays in bucket */
Tcl_HashTable handles; /* Hash table of given-out handles in bucket */
struct Container *freeCt; /* List of free Tcl-object containers */
} Bucket;
/*
* The following structure maintains the context for each variable array.
*/
typedef struct Array {
char *bindAddr; /* Array is bound to this address */
PsStore *psPtr; /* Persistent storage functions */
Bucket *bucketPtr; /* Array bucket. */
Tcl_HashEntry *entryPtr; /* Entry in bucket array table. */
Tcl_HashEntry *handlePtr; /* Entry in handles table */
Tcl_HashTable vars; /* Table of variables. */
} Array;
/*
* The object container for Tcl-objects stored within shared arrays.
*/
typedef struct Container {
Bucket *bucketPtr; /* Bucket holding the array below */
Array *arrayPtr; /* Array with the object container*/
Tcl_HashEntry *entryPtr; /* Entry in array table. */
Tcl_HashEntry *handlePtr; /* Entry in handles table */
Tcl_Obj *tclObj; /* Tcl object to hold shared values */
int epoch; /* Track object changes */
char *chunkAddr; /* Address of one chunk of object containers */
struct Container *nextPtr; /* Next object container in the free list */
int aolSpecial;
} Container;
/*
* Structure for generating command names in Tcl
*/
typedef struct SvCmdInfo {
char *name; /* The short name of the command */
char *cmdName; /* Real (rewritten) name of the command */
char *cmdName2; /* Real AOL (rewritten) name of the command */
Tcl_ObjCmdProc *objProcPtr; /* The object-based command procedure */
Tcl_CmdDeleteProc *delProcPtr; /* Pointer to command delete function */
struct SvCmdInfo *nextPtr; /* Next in chain of registered commands */
int aolSpecial;
} SvCmdInfo;
/*
* Structure for registering special object duplicator functions.
* Reason for this is that even some regular Tcl duplicators
* produce shallow instead of proper deep copies of the object.
* While this is considered to be ok in single-threaded apps,
* a multithreaded app could have problems when accessing objects
* which live in (i.e. are accessed from) different interpreters.
* So, for each object type which should be stored in shared object
* pools, we must assure that the object is copied properly.
*/
typedef struct RegType {
const Tcl_ObjType *typePtr; /* Type of the registered object */
Tcl_DupInternalRepProc *dupIntRepProc; /* Special deep-copy duper */
struct RegType *nextPtr; /* Next in chain of registered types */
} RegType;
/*
* Limited API functions
*/
MODULE_SCOPE void
Sv_RegisterCommand(const char*,Tcl_ObjCmdProc*,Tcl_CmdDeleteProc*, int);
MODULE_SCOPE void
Sv_RegisterObjType(const Tcl_ObjType*, Tcl_DupInternalRepProc*);
MODULE_SCOPE void
Sv_RegisterPsStore(const PsStore*);
MODULE_SCOPE int
Sv_GetContainer(Tcl_Interp*,int,Tcl_Obj*const objv[],Container**,int*,int);
MODULE_SCOPE int
Sv_PutContainer(Tcl_Interp*, Container*, int);
/*
* Private version of Tcl_DuplicateObj which takes care about
* copying objects when loaded to and retrieved from shared array.
*/
MODULE_SCOPE Tcl_Obj* Sv_DuplicateObj(Tcl_Obj*);
#endif /* _SV_H_ */
/* EOF $RCSfile: threadSvCmd.h,v $ */
/* Emacs Setup Variables */
/* Local Variables: */
/* mode: C */
/* indent-tabs-mode: nil */
/* c-basic-offset: 4 */
/* End: */

349
pkgs/thread2.8.7/generic/threadSvKeylistCmd.c Normal file
View File

@@ -0,0 +1,349 @@
/*
* threadSvKeylist.c --
*
* This file implements keyed-list commands as part of the thread
* shared variable implementation.
*
* Keyed list implementation is borrowed from Mark Diekhans and
* Karl Lehenbauer "TclX" (extended Tcl) extension. Please look
* into the keylist.c file for more information.
*
* See the file "license.txt" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* ---------------------------------------------------------------------------
*/
#include "threadSvCmd.h"
#include "threadSvKeylistCmd.h"
#include "tclXkeylist.h"
/*
* Wrapped keyed-list commands
*/
static Tcl_ObjCmdProc SvKeylsetObjCmd;
static Tcl_ObjCmdProc SvKeylgetObjCmd;
static Tcl_ObjCmdProc SvKeyldelObjCmd;
static Tcl_ObjCmdProc SvKeylkeysObjCmd;
/*
* This mutex protects a static variable which tracks
* registration of commands and object types.
*/
static Tcl_Mutex initMutex;
/*
*-----------------------------------------------------------------------------
*
* Sv_RegisterKeylistCommands --
*
* Register shared variable commands for TclX keyed lists.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Memory gets allocated
*
*-----------------------------------------------------------------------------
*/
void
Sv_RegisterKeylistCommands(void)
{
static int initialized;
if (initialized == 0) {
Tcl_MutexLock(&initMutex);
if (initialized == 0) {
Sv_RegisterCommand("keylset", SvKeylsetObjCmd, NULL, 0);
Sv_RegisterCommand("keylget", SvKeylgetObjCmd, NULL, 0);
Sv_RegisterCommand("keyldel", SvKeyldelObjCmd, NULL, 0);
Sv_RegisterCommand("keylkeys", SvKeylkeysObjCmd, NULL, 0);
Sv_RegisterObjType(&keyedListType, DupKeyedListInternalRepShared);
initialized = 1;
}
Tcl_MutexUnlock(&initMutex);
}
}
/*
*-----------------------------------------------------------------------------
*
* SvKeylsetObjCmd --
*
* This procedure is invoked to process the "tsv::keylset" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*-----------------------------------------------------------------------------
*/
static int
SvKeylsetObjCmd(
void *arg, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int i, off, ret, flg;
char *key;
Tcl_Obj *val;
Container *svObj = (Container*)arg;
/*
* Syntax:
* sv::keylset array lkey key value ?key value ...?
* $keylist keylset key value ?key value ...?
*/
flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR;
ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg);
if (ret != TCL_OK) {
return TCL_ERROR;
}
if ((objc - off) < 2 || ((objc - off) % 2)) {
Tcl_WrongNumArgs(interp, off, objv, "key value ?key value ...?");
goto cmd_err;
}
for (i = off; i < objc; i += 2) {
key = Tcl_GetString(objv[i]);
val = Sv_DuplicateObj(objv[i+1]);
ret = TclX_KeyedListSet(interp, svObj->tclObj, key, val);
if (ret != TCL_OK) {
goto cmd_err;
}
}
return Sv_PutContainer(interp, svObj, SV_CHANGED);
cmd_err:
return Sv_PutContainer(interp, svObj, SV_ERROR);
}
/*
*-----------------------------------------------------------------------------
*
* SvKeylgetObjCmd --
*
* This procedure is invoked to process the "tsv::keylget" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*-----------------------------------------------------------------------------
*/
static int
SvKeylgetObjCmd(
void *arg, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int ret, flg, off;
char *key;
Tcl_Obj *varObjPtr = NULL, *valObjPtr = NULL;
Container *svObj = (Container*)arg;
/*
* Syntax:
* sv::keylget array lkey ?key? ?var?
* $keylist keylget ?key? ?var?
*/
flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR;
ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg);
if (ret != TCL_OK) {
return TCL_ERROR;
}
if ((objc - off) > 2) {
Tcl_WrongNumArgs(interp, off, objv, "?key? ?var?");
goto cmd_err;
}
if ((objc - off) == 0) {
if (Sv_PutContainer(interp, svObj, SV_UNCHANGED) != TCL_OK) {
return TCL_ERROR;
}
return SvKeylkeysObjCmd(arg, interp, objc, objv);
}
if ((objc - off) == 2) {
varObjPtr = objv[off+1];
} else {
varObjPtr = NULL;
}
key = Tcl_GetString(objv[off]);
ret = TclX_KeyedListGet(interp, svObj->tclObj, key, &valObjPtr);
if (ret == TCL_ERROR) {
goto cmd_err;
}
if (ret == TCL_BREAK) {
if (varObjPtr) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
} else {
Tcl_AppendResult (interp, "key \"", key, "\" not found", NULL);
goto cmd_err;
}
} else {
Tcl_Obj *resObjPtr = Sv_DuplicateObj(valObjPtr);
if (varObjPtr) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
Tcl_GetString(varObjPtr);
if (varObjPtr->length) {
Tcl_ObjSetVar2(interp, varObjPtr, NULL, resObjPtr, 0);
}
} else {
Tcl_SetObjResult(interp, resObjPtr);
}
}
return Sv_PutContainer(interp, svObj, SV_UNCHANGED);
cmd_err:
return Sv_PutContainer(interp, svObj, SV_ERROR);
}
/*
*-----------------------------------------------------------------------------
*
* SvKeyldelObjCmd --
*
* This procedure is invoked to process the "tsv::keyldel" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*-----------------------------------------------------------------------------
*/
static int
SvKeyldelObjCmd(
void *arg, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int i, off, ret;
char *key;
Container *svObj = (Container*)arg;
/*
* Syntax:
* sv::keyldel array lkey key ?key ...?
* $keylist keyldel ?key ...?
*/
ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
if (ret != TCL_OK) {
return TCL_ERROR;
}
if ((objc - off) < 1) {
Tcl_WrongNumArgs(interp, off, objv, "key ?key ...?");
goto cmd_err;
}
for (i = off; i < objc; i++) {
key = Tcl_GetString(objv[i]);
ret = TclX_KeyedListDelete(interp, svObj->tclObj, key);
if (ret == TCL_BREAK) {
Tcl_AppendResult(interp, "key \"", key, "\" not found", NULL);
}
if (ret == TCL_BREAK || ret == TCL_ERROR) {
goto cmd_err;
}
}
return Sv_PutContainer(interp, svObj, SV_CHANGED);
cmd_err:
return Sv_PutContainer(interp, svObj, SV_ERROR);
}
/*
*-----------------------------------------------------------------------------
*
* SvKeylkeysObjCmd --
*
* This procedure is invoked to process the "tsv::keylkeys" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*-----------------------------------------------------------------------------
*/
static int
SvKeylkeysObjCmd(
void *arg, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int ret, off;
char *key = NULL;
Tcl_Obj *listObj = NULL;
Container *svObj = (Container*)arg;
/*
* Syntax:
* sv::keylkeys array lkey ?key?
* $keylist keylkeys ?key?
*/
ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
if (ret != TCL_OK) {
return TCL_ERROR;
}
if ((objc - off) > 1) {
Tcl_WrongNumArgs(interp, 1, objv, "?lkey?");
goto cmd_err;
}
if ((objc - off) == 1) {
key = Tcl_GetString(objv[off]);
}
ret = TclX_KeyedListGetKeys(interp, svObj->tclObj, key, &listObj);
if (key && ret == TCL_BREAK) {
Tcl_AppendResult(interp, "key \"", key, "\" not found", NULL);
}
if (ret == TCL_BREAK || ret == TCL_ERROR) {
goto cmd_err;
}
Tcl_SetObjResult (interp, listObj); /* listObj allocated by API !*/
return Sv_PutContainer(interp, svObj, SV_UNCHANGED);
cmd_err:
return Sv_PutContainer(interp, svObj, SV_ERROR);
}
/* EOF $RCSfile: threadSvKeylistCmd.c,v $ */
/* Emacs Setup Variables */
/* Local Variables: */
/* mode: C */
/* indent-tabs-mode: nil */
/* c-basic-offset: 4 */
/* End: */

27
pkgs/thread2.8.7/generic/threadSvKeylistCmd.h Normal file
View File

@@ -0,0 +1,27 @@
/*
* threadSvKeylistCmd.h --
*
* See the file "license.txt" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* ---------------------------------------------------------------------------
*/
#ifndef _KEYLISTCMDS_H_
#define _KEYLISTCMDS_H_
#include "tclThreadInt.h"
MODULE_SCOPE void Sv_RegisterKeylistCommands(void);
MODULE_SCOPE void TclX_KeyedListInit(Tcl_Interp *interp);
#endif /* _KEYLISTCMDS_H_ */
/* EOF $RCSfile: threadSvKeylistCmd.h,v $ */
/* Emacs Setup Variables */
/* Local Variables: */
/* mode: C */
/* indent-tabs-mode: nil */
/* c-basic-offset: 4 */
/* End: */

1080
pkgs/thread2.8.7/generic/threadSvListCmd.c Normal file
View File

File diff suppressed because it is too large Load Diff

24
pkgs/thread2.8.7/generic/threadSvListCmd.h Normal file
View File

@@ -0,0 +1,24 @@
/*
* Copyright (c) 2002 by Zoran Vasiljevic.
*
* See the file "license.txt" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* ---------------------------------------------------------------------------
*/
#ifndef _SV_LIST_H_
#define _SV_LIST_H_
MODULE_SCOPE void Sv_RegisterListCommands();
#endif /* _SV_LIST_H_ */
/* EOF $RCSfile: threadSvListCmd.h,v $ */
/* Emacs Setup Variables */
/* Local Variables: */
/* mode: C */
/* indent-tabs-mode: nil */
/* c-basic-offset: 4 */
/* End: */

942
pkgs/thread2.8.7/lib/ttrace.tcl Normal file
View File

@@ -0,0 +1,942 @@
#
# ttrace.tcl --
#
# Copyright (C) 2003 Zoran Vasiljevic, Archiware GmbH. All Rights Reserved.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# ----------------------------------------------------------------------------
#
# User level commands:
#
# ttrace::eval top-level wrapper (ttrace-savvy eval)
# ttrace::enable activates registered Tcl command traces
# ttrace::disable terminates tracing of Tcl commands
# ttrace::isenabled returns true if ttrace is enabled
# ttrace::cleanup bring the interp to a pristine state
# ttrace::update update interp to the latest trace epoch
# ttrace::config setup some configuration options
# ttrace::getscript returns a script for initializing interps
#
# Commands used for/from trace callbacks:
#
# ttrace::atenable register callback to be done at trace enable
# ttrace::atdisable register callback to be done at trace disable
# ttrace::addtrace register user-defined tracer callback
# ttrace::addscript register user-defined script generator
# ttrace::addresolver register user-defined command resolver
# ttrace::addcleanup register user-defined cleanup procedures
# ttrace::addentry adds one entry into the named trace store
# ttrace::getentry returns the entry value from the named store
# ttrace::delentry removes the entry from the named store
# ttrace::getentries returns all entries from the named store
# ttrace::preload register procedures to be preloaded always
#
#
# Limitations:
#
# o. [namespace forget] is still not implemented
# o. [namespace origin cmd] breaks if cmd is not already defined
#
# I left this deliberately. I didn't want to override the [namespace]
# command in order to avoid potential slowdown.
#
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
} elseif {![catch {
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
} else {
error "requires NaviServer/AOLserver or Tcl threading extension"
}
# Keep in sync with the Thread package
package provide Ttrace 2.8.7
# Package variables
variable resolvers "" ; # List of registered resolvers
variable tracers "" ; # List of registered cmd tracers
variable scripts "" ; # List of registered script makers
variable enables "" ; # List of trace-enable callbacks
variable disables "" ; # List of trace-disable callbacks
variable preloads "" ; # List of procedure names to preload
variable enabled 0 ; # True if trace is enabled
variable config ; # Array with config options
variable epoch -1 ; # The initialization epoch
variable cleancnt 0 ; # Counter of registered cleaners
# Package private namespaces
namespace eval resolve "" ; # Commands for resolving commands
namespace eval trace "" ; # Commands registered for tracing
namespace eval enable "" ; # Commands invoked at trace enable
namespace eval disable "" ; # Commands invoked at trace disable
namespace eval script "" ; # Commands for generating scripts
# Exported commands
namespace export unknown
# Initialize ttrace shared state
if {[_array exists ttrace] == 0} {
_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
}
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
}
}
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
}
}
}
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
}
}
}
proc isenabled {} {
variable enabled
expr {$enabled > 0}
}
proc update {{from -1}} {
if {$from == -1} {
variable epoch [_set ttrace lastepoch]
} else {
if {[lsearch [_set ttrace epochlist] $from] == -1} {
error "no such epoch: $from"
}
variable epoch $from
}
uplevel [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
}
proc cleanup {args} {
foreach cmd [info commands resolve::cleaner_*] {
uplevel $cmd $args
}
}
proc preload {cmd} {
variable preloads
if {[lsearch $preloads $cmd] == -1} {
lappend preloads $cmd
}
}
proc atenable {cmd arglist body} {
variable enables
if {[lsearch $enables $cmd] == -1} {
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] == -1} {
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] == -1} {
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] == -1} {
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] == -1} {
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
}
proc addentry {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
}
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
}
proc getentries {cmd {pattern *}} {
variable epoch
_array names ${epoch}-$cmd $pattern
}
proc unknown {args} {
set cmd [lindex $args 0]
if {[uplevel ttrace::_resolve [list $cmd]]} {
set c [catch {uplevel $cmd [lrange $args 1 end]} r]
} else {
set c [catch {::eval ::tcl::unknown $args} r]
}
return -code $c -errorcode $::errorCode -errorinfo $::errorInfo $r
}
proc _resolve {cmd} {
variable resolvers
foreach resolver $resolvers {
if {[uplevel [info comm resolve::$resolver] [list $cmd]]} {
return 1
}
}
return 0
}
proc _getthread {} {
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
}
}
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
}
proc _copyepoch {old new} {
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
}
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
}
}
proc _useepoch {epoch} {
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
}
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
}
}
#
# The code below is ment to be run once during the application start. It
# provides implementation of tracing callbacks for some Tcl commands. Users
# can supply their own tracer implementations on-the-fly.
#
# The code below will create traces for the following Tcl commands:
# "namespace", "variable", "load", "proc" and "rename"
#
# Also, the Tcl object extension XOTcl 1.1.0 is handled and all XOTcl related
# things, like classes and objects are traced (many thanks to Gustaf Neumann
# from XOTcl for his kind help and support).
#
eval {
#
# Register the "load" trace. This will create the following key/value pair
# in the "load" store:
#
# --- key ---- --- value ---
# <path_of_loaded_image> <name_of_the_init_proc>
#
# We normally need only the name_of_the_init_proc for being able to load
# the package in other interpreters, but we store the path to the image
# file as well.
#
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
}
ttrace::addscript load {
append res "\n"
foreach entry [ttrace::getentries load] {
set initp [ttrace::getentry load $entry]
append res "::load {} $initp" \n
}
return $res
}
#
# Register the "namespace" trace. This will create the following key/value
# entry in "namespace" store:
#
# --- key ---- --- value ---
# ::fully::qualified::namespace 1
#
# It will also fill the "proc" store for procedures and commands imported
# in this namespace with following:
#
# --- key ---- --- value ---
# ::fully::qualified::proc [list <ns> "" ""]
#
# The <ns> is the name of the namespace where the command or procedure is
# imported from.
#
ttrace::addtrace namespace {cmdline code args} {
if {$code != 0} {
return
}
set nop [lindex $cmdline 1]
set cns [uplevel 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
}
#
# Register the "variable" trace. This will create the following key/value
# entry in the "variable" store:
#
# --- key ---- --- value ---
# ::fully::qualified::variable 1
#
# The variable value itself is ignored at the time of
# trace/collection. Instead, we take the real value at the time of script
# generation.
#
ttrace::addtrace variable {cmdline code args} {
if {$code != 0} {
return
}
set opts [lrange $cmdline 1 end]
if {[llength $opts]} {
set cns [uplevel 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
}
#
# Register the "rename" trace. It will create the following key/value pair
# in "rename" store:
#
# --- key ---- --- value ---
# ::fully::qualified::old ::fully::qualified::new
#
# The "new" value may be empty, for commands that have been deleted. In
# such cases we also remove any traced procedure definitions.
#
ttrace::addtrace rename {cmdline code args} {
if {$code != 0} {
return
}
set cns [uplevel 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
}
#
# Register the "proc" trace. This will create the following key/value pair
# in the "proc" store:
#
# --- key ---- --- value ---
# ::fully::qualified::proc [list <epoch> <ns> <arglist> <body>]
#
# The <epoch> chages anytime one (re)defines a proc. The <ns> is the
# namespace where the command was imported from. If empty, the <arglist>
# and <body> will hold the actual procedure definition. See the
# "namespace" tracer implementation also.
#
ttrace::addtrace proc {cmdline code args} {
if {$code != 0} {
return
}
set cns [uplevel 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 ::tcl::info $args}]} {
uplevel ttrace::_resolve [list [lindex $args 1]]
}
return [uplevel ::tcl::info $args]
}
if {$hit == -1} {
return [uplevel ::tcl::info $args]
}
set cns [uplevel 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 ::tcl::info $args] {
set lazy($entry) 1
}
array names lazy
}
}
}
#
# Register procedure resolver. This will try to resolve the command in the
# current namespace first, and if not found, in global namespace. It also
# handles commands imported from other namespaces.
#
ttrace::addresolver resolveprocs {cmd {export 0}} {
set cns [uplevel 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
}
#
# For XOTcl, the entire item introspection/tracing is delegated to XOTcl
# itself. The xotcl store is filled with this:
#
# --- key ---- --- value ---
# ::fully::qualified::item <body>
#
# The <body> is the script used to generate the entire item (class,
# object). Note that we do not fill in this during code tracing. It is
# done during the script generation. In this step, only the placeholder is
# set.
#
# NOTE: we assume all XOTcl commands are imported in global namespace
#
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
}
ttrace::atdisable XOTclDisabler {args} {
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 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 [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}}
}
}]
#
# Register callback to be called on cleanup. This will trash lazily loaded
# procs which have changed since.
#
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 ""}
}
}
}
}
}
# EOF
return
# Local Variables:
# mode: tcl
# fill-column: 78
# tab-width: 8
# indent-tabs-mode: nil
# End:

39
pkgs/thread2.8.7/license.terms Normal file
View File

@@ -0,0 +1,39 @@
This software is copyrighted by the Regents of the University of
California, Sun Microsystems, Inc., Scriptics Corporation,
and other parties. The following terms apply to all files associated
with the software unless explicitly disclaimed in individual files.
The authors hereby grant permission to use, copy, modify, distribute,
and license this software and its documentation for any purpose, provided
that existing copyright notices are retained in all copies and that this
notice is included verbatim in any distributions. No written agreement,
license, or royalty fee is required for any of the authorized uses.
Modifications to this software may be copyrighted by their authors
and need not follow the licensing terms described here, provided that
the new terms are clearly indicated on the first page of each file where
they apply.
IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
MODIFICATIONS.
GOVERNMENT USE: If you are acquiring this software on behalf of the
U.S. government, the Government shall have only "Restricted Rights"
in the software and related documentation as defined in the Federal
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
are acquiring the software on behalf of the Department of Defense, the
software shall be classified as "Commercial Computer Software" and the
Government shall have only "Restricted Rights" as defined in Clause
252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
authors grant the U.S. Government and others acting in its behalf
permission to use and distribute the software in accordance with the
terms specified in this license.

1
pkgs/thread2.8.7/manifest.uuid Normal file
View File

@@ -0,0 +1 @@
90040000d98db8fd148c7969faa533276ad9e69a49bdee53209f10f549eb8475

57
pkgs/thread2.8.7/naviserver.m4 Normal file
View File

@@ -0,0 +1,57 @@
#------------------------------------------------------------------------
# NS_PATH_AOLSERVER
#
# Allows the building with support for NaviServer/AOLserver
#
# Arguments:
# none
#
# Results:
#
# Adds the following arguments to configure:
# --with-naviserver=...
#
# Defines the following vars:
# NS_DIR Full path to the directory containing NaviServer/AOLserver distro
# NS_INCLUDES
# NS_LIBS
#
# Sets the following vars:
# NS_AOLSERVER
#
# Updates following vars:
#------------------------------------------------------------------------
AC_DEFUN(NS_PATH_AOLSERVER, [
AC_MSG_CHECKING([for NaviServer/AOLserver configuration])
AC_ARG_WITH(naviserver,
[ --with-naviserver directory with NaviServer/AOLserver distribution],\
with_naviserver=${withval})
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
fi
])
if test x"${ac_cv_c_naviserver}" = x ; then
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)
fi
])
# EOF

68
pkgs/thread2.8.7/pkgIndex.tcl.in Normal file
View File

@@ -0,0 +1,68 @@
# -*- tcl -*-
# Tcl package index file, version 1.1
#
if {![package vsatisfies [package provide Tcl] 8.4]} {
# Pre-8.4 Tcl interps we dont support at all. Bye!
# 9.0+ Tcl interps are only supported on 32-bit platforms.
if {![package vsatisfies [package provide Tcl] 9.0]
|| ($::tcl_platform(pointerSize) != 4)} {
return
}
}
# All Tcl 8.4+ interps can [load] Thread @PACKAGE_VERSION@
#
# For interps that are not thread-enabled, we still call [package ifneeded].
# This is contrary to the usual convention, but is a good idea because we
# cannot imagine any other version of Thread that might succeed in a
# thread-disabled interp. There's nothing to gain by yielding to other
# competing callers of [package ifneeded Thread]. On the other hand,
# deferring the error has the advantage that a script calling
# [package require Thread] in a thread-disabled interp gets an error message
# about a thread-disabled interp, instead of the message
# "can't find package Thread".
package ifneeded Thread @PACKAGE_VERSION@ [list load [file join $dir @PKG_LIB_FILE@] [string totitle @PACKAGE_NAME@]]
# package Ttrace uses some support machinery.
# In Tcl 8.4 interps we use some older interfaces
if {![package vsatisfies [package provide Tcl] 8.5]} {
package ifneeded Ttrace @PACKAGE_VERSION@ "
[list proc @PACKAGE_NAME@_source {dir} {
if {[info exists ::env(TCL_THREAD_LIBRARY)] &&
[file readable $::env(TCL_THREAD_LIBRARY)/ttrace.tcl]} {
source $::env(TCL_THREAD_LIBRARY)/ttrace.tcl
} elseif {[file readable [file join $dir .. lib ttrace.tcl]]} {
source [file join $dir .. lib ttrace.tcl]
} elseif {[file readable [file join $dir ttrace.tcl]]} {
source [file join $dir ttrace.tcl]
}
if {[namespace which ::ttrace::update] ne ""} {
::ttrace::update
}
}]
[list @PACKAGE_NAME@_source $dir]
[list rename @PACKAGE_NAME@_source {}]"
return
}
# In Tcl 8.5+ interps; use [::apply]
package ifneeded Ttrace @PACKAGE_VERSION@ [list ::apply {{dir} {
if {[info exists ::env(TCL_THREAD_LIBRARY)] &&
[file readable $::env(TCL_THREAD_LIBRARY)/ttrace.tcl]} {
source $::env(TCL_THREAD_LIBRARY)/ttrace.tcl
} elseif {[file readable [file join $dir .. lib ttrace.tcl]]} {
source [file join $dir .. lib ttrace.tcl]
} elseif {[file readable [file join $dir ttrace.tcl]]} {
source [file join $dir ttrace.tcl]
}
if {[namespace which ::ttrace::update] ne ""} {
::ttrace::update
}
}} $dir]

32
pkgs/thread2.8.7/tcl/README Normal file
View File

@@ -0,0 +1,32 @@
Software here is provided as example of making some interesting
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.
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.
cmdsrv/ Socket command-line server. Each new connection
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.4 (or later) Tcl shell.
Be sure to have the latest Tcl threading extension installed in
your package path.
- EOF

310
pkgs/thread2.8.7/tcl/cmdsrv/cmdsrv.tcl Normal file
View File

@@ -0,0 +1,310 @@
#
# cmdsrv.tcl --
#
# Simple socket command server. Supports many simultaneous sessions.
# Works in thread mode with each new connection receiving a new thread.
#
# Usage:
# cmdsrv::create port ?-idletime value? ?-initcmd cmd?
#
# port Tcp port where the server listens
# -idletime # of sec to idle before tearing down socket (def: 300 sec)
# -initcmd script to initialize new worker thread (def: empty)
#
# Example:
#
# # tclsh8.6
# % source cmdsrv.tcl
# % cmdsrv::create 5000 -idletime 60
# % vwait forever
#
# Starts the server on the port 5000, sets idle timer to 1 minute.
# You can now use "telnet" utility to connect.
#
# Copyright (c) 2002 by Zoran Vasiljevic.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -----------------------------------------------------------------------------
package require Tcl 8.4
package require Thread 2.5
namespace eval cmdsrv {
variable data; # Stores global configuration options
}
#
# cmdsrv::create --
#
# Start the server on the given Tcp port.
#
# Arguments:
# port Port where the server is listening
# args Variable number of arguments
#
# Side Effects:
# None.
#
# Results:
# None.
#
proc cmdsrv::create {port args} {
variable data
if {[llength $args] % 2} {
error "wrong \# arguments, should be: key1 val1 key2 val2..."
}
#
# Setup default pool data.
#
array set data {
-idletime 300000
-initcmd {source cmdsrv.tcl}
}
#
# Override with user-supplied data
#
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\""
}
}
}
#
# Start the server on the given port. Note that we wrap
# the actual accept with a helper after/idle callback.
# This is a workaround for a well-known Tcl bug.
#
socket -server [namespace current]::_Accept -myaddr 127.0.0.1 $port
}
#
# cmdsrv::_Accept --
#
# Helper procedure to solve Tcl shared channel bug when responding
# to incoming socket connection and transfering the channel to other
# thread(s).
#
# Arguments:
# s incoming socket
# ipaddr IP address of the remote peer
# port Tcp port used for this connection
#
# Side Effects:
# None.
#
# Results:
# None.
#
proc cmdsrv::_Accept {s ipaddr port} {
after idle [list [namespace current]::Accept $s $ipaddr $port]
}
#
# cmdsrv::Accept --
#
# Accepts the incoming socket connection, creates the worker thread.
#
# Arguments:
# s incoming socket
# ipaddr IP address of the remote peer
# port Tcp port used for this connection
#
# Side Effects:
# Creates new worker thread.
#
# Results:
# None.
#
proc cmdsrv::Accept {s ipaddr port} {
variable data
#
# Configure socket for sane operation
#
fconfigure $s -blocking 0 -buffering none -translation {auto crlf}
#
# Emit the prompt
#
puts -nonewline $s "% "
#
# Create worker thread and transfer socket ownership
#
set tid [thread::create [append data(-initcmd) \n thread::wait]]
thread::transfer $tid $s ; # This flushes the socket as well
#
# Start event-loop processing in the remote thread
#
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
}]
}
#
# cmdsrv::Read --
#
# Event loop procedure to read data from socket and collect the
# command to execute. If the command read from socket is complete
# it executes the command are prints the result back.
#
# Arguments:
# s incoming socket
#
# Side Effects:
# None.
#
# Results:
# None.
#
proc cmdsrv::Read {s} {
variable data
StopIdleTimer $s
#
# Cover client closing connection
#
if {[eof $s] || [catch {read $s} line]} {
return [SockDone $s]
}
if {$line == "\n" || $line == ""} {
if {[catch {puts -nonewline $s "% "}]} {
return [SockDone $s]
}
return [StartIdleTimer $s]
}
#
# Construct command line to eval
#
append data(cmd) $line
if {[info complete $data(cmd)] == 0} {
if {[catch {puts -nonewline $s "> "}]} {
return [SockDone $s]
}
return [StartIdleTimer $s]
}
#
# Run the command
#
catch {uplevel \#0 $data(cmd)} ret
if {[catch {puts $s $ret}]} {
return [SockDone $s]
}
set data(cmd) ""
if {[catch {puts -nonewline $s "% "}]} {
return [SockDone $s]
}
StartIdleTimer $s
}
#
# cmdsrv::SockDone --
#
# Tears down the thread and closes the socket if the remote peer has
# closed his side of the comm channel.
#
# Arguments:
# s incoming socket
#
# Side Effects:
# Worker thread gets released.
#
# Results:
# None.
#
proc cmdsrv::SockDone {s} {
catch {close $s}
thread::release
}
#
# cmdsrv::StopIdleTimer --
#
# Cancel the connection idle timer.
#
# Arguments:
# s incoming socket
#
# Side Effects:
# After event gets cancelled.
#
# Results:
# None.
#
proc cmdsrv::StopIdleTimer {s} {
variable data
if {[info exists data(idleevent)]} {
after cancel $data(idleevent)
unset data(idleevent)
}
}
#
# cmdsrv::StartIdleTimer --
#
# Initiates the connection idle timer.
#
# Arguments:
# s incoming socket
#
# Side Effects:
# After event gets posted.
#
# Results:
# None.
#
proc cmdsrv::StartIdleTimer {s} {
variable data
set data(idleevent) \
[after $data(-idletime) [list [namespace current]::SockDone $s]]
}
# EOF $RCSfile: cmdsrv.tcl,v $
# Emacs Setup Variables
# Local Variables:
# mode: Tcl
# indent-tabs-mode: nil
# tcl-basic-offset: 4
# End:

5
pkgs/thread2.8.7/tcl/phttpd/index.htm Normal file
View File

@@ -0,0 +1,5 @@
<html>
<body>
<h3>Hallo World</h3>
</body>
</html>

686
pkgs/thread2.8.7/tcl/phttpd/phttpd.tcl Normal file
View File

@@ -0,0 +1,686 @@
#
# phttpd.tcl --
#
# Simple Sample httpd/1.0 server in 250 lines of Tcl.
# Stephen Uhler / Brent Welch (c) 1996 Sun Microsystems.
#
# Modified to use namespaces, direct url-to-procedure access
# and thread pool package. Grown little larger since ;)
#
# Usage:
# phttpd::create port
#
# port Tcp port where the server listens
#
# Example:
#
# # tclsh8.6
# % source phttpd.tcl
# % phttpd::create 5000
# % vwait forever
#
# Starts the server on the port 5000. Also, look at the Httpd array
# definition in the "phttpd" namespace declaration to find out
# about other options you may put on the command line.
#
# You can use: http://localhost:5000/monitor URL to test the
# server functionality.
#
# Copyright (c) 2002 by Zoran Vasiljevic.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -----------------------------------------------------------------------------
package require Tcl 8.4
package require Thread 2.5
#
# Modify the following in order to load the
# example Tcl implementation of threadpools.
# Per default, the C-level threadpool is used.
#
if {0} {
eval [set TCL_TPOOL {source ../tpool/tpool.tcl}]
}
namespace eval phttpd {
variable Httpd; # Internal server state and config params
variable MimeTypes; # Cache of file-extension/mime-type
variable HttpCodes; # Portion of well-known http return codes
variable ErrorPage; # Format of error response page in html
array set Httpd {
-name phttpd
-vers 1.0
-root "."
-index index.htm
}
array set HttpCodes {
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"
}
set ErrorPage {
<title>Error: %1$s %2$s</title>
<h1>%3$s</h1>
<p>Problem in accessing "%4$s" on this server.</p>
<hr>
<i>%5$s/%6$s Server at %7$s Port %8$s</i>
}
}
#
# phttpd::create --
#
# Start the server by listening for connections on the desired port.
#
# Arguments:
# port
# args
#
# Side Effects:
# None..
#
# Results:
# None.
#
proc phttpd::create {port args} {
variable Httpd
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] == -1} {
error "unknown option \"$arg\""
}
set Httpd($arg) $val
}
}
#
# Create thread pool with max 8 worker threads.
#
if {[info exists ::TCL_TPOOL] == 0} {
#
# 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
}
set Httpd(tpid) [tpool::create -maxworkers 8 -initcmd $initcmd]
#
# Start the server on the given port. Note that we wrap
# the actual accept with a helper after/idle callback.
# This is a workaround for a well-known Tcl bug.
#
socket -server [namespace current]::_Accept $port
}
#
# phttpd::_Accept --
#
# Helper procedure to solve Tcl shared-channel bug when responding
# to incoming connection and transfering the channel to other thread(s).
#
# Arguments:
# sock incoming socket
# ipaddr IP address of the remote peer
# port Tcp port used for this connection
#
# Side Effects:
# None.
#
# Results:
# None.
#
proc phttpd::_Accept {sock ipaddr port} {
after idle [list [namespace current]::Accept $sock $ipaddr $port]
}
#
# phttpd::Accept --
#
# Accept a new connection from the client.
#
# Arguments:
# sock
# ipaddr
# port
#
# Side Effects:
# None..
#
# Results:
# None.
#
proc phttpd::Accept {sock ipaddr port} {
variable Httpd
#
# Setup the socket for sane operation
#
fconfigure $sock -blocking 0 -translation {auto crlf}
#
# Detach the socket from current interpreter/tnread.
# One of the worker threads will attach it again.
#
thread::detach $sock
#
# Send the work ticket to threadpool.
#
tpool::post -detached $Httpd(tpid) [list [namespace current]::Ticket $sock]
}
#
# phttpd::Ticket --
#
# Job ticket to run in the thread pool thread.
#
# Arguments:
# sock
#
# Side Effects:
# None..
#
# Results:
# None.
#
proc phttpd::Ticket {sock} {
thread::attach $sock
fileevent $sock readable [list [namespace current]::Read $sock]
#
# End of processing is signalized here.
# This will release the worker thread.
#
vwait [namespace current]::done
}
#
# phttpd::Read --
#
# Read data from client and parse incoming http request.
#
# Arguments:
# sock
#
# Side Effects:
# None.
#
# Results:
# None.
#
proc phttpd::Read {sock} {
variable Httpd
variable data
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]
}
}
}
}
}
#
# phttpd::Done --
#
# Close the connection socket
#
# Arguments:
# s
#
# Side Effects:
# None..
#
# Results:
# None.
#
proc phttpd::Done {} {
variable done
variable data
close $data(sock)
if {[info exists data]} {
unset data
}
set done 1 ; # Releases the request thread (See Ticket procedure)
}
#
# phttpd::Respond --
#
# Respond to the query.
#
# Arguments:
# s
#
# Side Effects:
# None..
#
# Results:
# None.
#
proc phttpd::Respond {} {
variable data
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
}
} 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
}
}
}
#
# phttpd::ContentType --
#
# Convert the file suffix into a mime type.
#
# Arguments:
# path
#
# Side Effects:
# None..
#
# Results:
# None.
#
proc phttpd::ContentType {path} {
# @c Convert the file suffix into a mime type.
variable MimeTypes
set type "text/plain"
catch {set type $MimeTypes([file extension $path])}
return $type
}
#
# phttpd::Error --
#
# Emit error page
#
# Arguments:
# s
# code
#
# Side Effects:
# None..
#
# Results:
# None.
#
proc phttpd::Error {code} {
variable Httpd
variable HttpCodes
variable ErrorPage
variable data
append data(url) ""
set msg \
[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
} err]} {
Log error "client closed connection prematurely: %s" $err
}
}
#
# phttpd::Date --
#
# Generate a date string in HTTP format.
#
# Arguments:
# seconds
#
# Side Effects:
# None..
#
# Results:
# None.
#
proc phttpd::Date {{seconds 0}} {
# @c Generate a date string in HTTP format.
if {$seconds == 0} {
set seconds [clock seconds]
}
clock format $seconds -format {%a, %d %b %Y %T %Z} -gmt 1
}
#
# phttpd::Log --
#
# Log an httpd transaction.
#
# Arguments:
# reason
# format
# args
#
# Side Effects:
# None..
#
# Results:
# None.
#
proc phttpd::Log {reason format args} {
set messg [eval format [list $format] $args]
set stamp [clock format [clock seconds] -format "%d/%b/%Y:%H:%M:%S"]
puts stderr "\[$stamp\]\[-thread[thread::id]-\] $reason: $messg"
}
#
# phttpd::Url2File --
#
# Convert a url into a pathname.
#
# Arguments:
# url
#
# Side Effects:
# None..
#
# Results:
# None.
#
proc phttpd::Url2File {url} {
variable Httpd
lappend pathlist $Httpd(-root)
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 file [eval file join $pathlist]
if {[file isdirectory $file]} {
return [file join $file $Httpd(-index)]
} else {
return $file
}
}
#
# phttpd::CgiMap --
#
# Decode url-encoded strings.
#
# Arguments:
# data
#
# Side Effects:
# None..
#
# Results:
# None.
#
proc phttpd::CgiMap {data} {
regsub -all {\+} $data { } data
regsub -all {([][$\\])} $data {\\\1} data
regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data
return [subst $data]
}
#
# phttpd::QueryMap --
#
# Decode url-encoded query into key/value pairs.
#
# Arguments:
# query
#
# Side Effects:
# None..
#
# Results:
# None.
#
proc phttpd::QueryMap {query} {
set res [list]
regsub -all {[&=]} $query { } query
regsub -all { } $query { {} } query; # Othewise we lose empty values
foreach {key val} $query {
lappend res [CgiMap $key] [CgiMap $val]
}
return $res
}
#
# monitor --
#
# Procedure used to test the phttpd server. It responds on the
# http://<hostname>:<port>/monitor
#
# Arguments:
# array
#
# Side Effects:
# None..
#
# Results:
# None.
#
proc /monitor {array} {
upvar $array data ; # Holds the socket to remote client
#
# Emit headers
#
puts $data(sock) "HTTP/1.0 200 OK"
puts $data(sock) "Date: [phttpd::Date]"
puts $data(sock) "Content-Type: text/html"
puts $data(sock) ""
#
# Emit body
#
puts $data(sock) [subst {
<html>
<body>
<h3>[clock format [clock seconds]]</h3>
}]
after 1 ; # Simulate blocking call
puts $data(sock) [subst {
</body>
</html>
}]
}
# EOF $RCSfile: phttpd.tcl,v $
# Emacs Setup Variables
# Local Variables:
# mode: Tcl
# indent-tabs-mode: nil
# tcl-basic-offset: 4
# End:

416
pkgs/thread2.8.7/tcl/phttpd/uhttpd.tcl Normal file
View File

@@ -0,0 +1,416 @@
#
# uhttpd.tcl --
#
# Simple Sample httpd/1.0 server in 250 lines of Tcl.
# Stephen Uhler / Brent Welch (c) 1996 Sun Microsystems.
#
# Modified to use namespaces and direct url-to-procedure access (zv).
# Eh, due to this, and nicer indenting, it's now 150 lines longer :-)
#
# Usage:
# phttpd::create port
#
# port Tcp port where the server listens
#
# Example:
#
# # tclsh8.6
# % source uhttpd.tcl
# % uhttpd::create 5000
# % vwait forever
#
# Starts the server on the port 5000. Also, look at the Httpd array
# definition in the "uhttpd" namespace declaration to find out
# about other options you may put on the command line.
#
# You can use: http://localhost:5000/monitor URL to test the
# server functionality.
#
# Copyright (c) Stephen Uhler / Brent Welch (c) 1996 Sun Microsystems.
# Copyright (c) 2002 by Zoran Vasiljevic.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -----------------------------------------------------------------------------
namespace eval uhttpd {
variable Httpd; # Internal server state and config params
variable MimeTypes; # Cache of file-extension/mime-type
variable HttpCodes; # Portion of well-known http return codes
variable ErrorPage; # Format of error response page in html
array set Httpd {
-name uhttpd
-vers 1.0
-root ""
-index index.htm
}
array set HttpCodes {
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"
}
set ErrorPage {
<title>Error: %1$s %2$s</title>
<h1>%3$s</h1>
<p>Problem in accessing "%4$s" on this server.</p>
<hr>
<i>%5$s/%6$s Server at %7$s Port %8$s</i>
}
}
proc uhttpd::create {port args} {
# @c Start the server by listening for connections on the desired port.
variable Httpd
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] == -1} {
error "unknown option \"$arg\""
}
set Httpd($arg) $val
}
}
set Httpd(port) $port
set Httpd(host) [info hostname]
socket -server [namespace current]::Accept $port
}
proc uhttpd::respond {s status contype data {length 0}} {
puts $s "HTTP/1.0 $status"
puts $s "Date: [Date]"
puts $s "Content-Type: $contype"
if {$length} {
puts $s "Content-Length: $length"
} else {
puts $s "Content-Length: [string length $data]"
}
puts $s ""
puts $s $data
}
proc uhttpd::Accept {newsock ipaddr port} {
# @c Accept a new connection from the client.
variable Httpd
upvar \#0 [namespace current]::Httpd$newsock data
fconfigure $newsock -blocking 0 -translation {auto crlf}
set data(ipaddr) $ipaddr
fileevent $newsock readable [list [namespace current]::Read $newsock]
}
proc uhttpd::Read {s} {
# @c Read data from client
variable Httpd
upvar \#0 [namespace current]::Httpd$s data
if {[catch {gets $s line} readCount] || [eof $s]} {
return [Done $s]
}
if {$readCount == -1} {
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]
}
}
# 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]
}
}
}
}
proc uhttpd::Done {s} {
# @c Close the connection socket and discard token
close $s
unset [namespace current]::Httpd$s
}
proc uhttpd::Respond {s} {
# @c Respond to the query.
variable Httpd
upvar \#0 [namespace current]::Httpd$s data
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
}
} 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
}
}
Done $s
}
proc uhttpd::ContentType {path} {
# @c Convert the file suffix into a mime type.
variable MimeTypes
set type "text/plain"
catch {set type $MimeTypes([file extension $path])}
return $type
}
proc uhttpd::Error {s code} {
# @c Emit error page.
variable Httpd
variable HttpCodes
variable ErrorPage
upvar \#0 [namespace current]::Httpd$s data
append data(url) ""
set msg \
[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
} err]} {
Log error "client closed connection prematurely: %s" $err
}
}
proc uhttpd::Date {{seconds 0}} {
# @c Generate a date string in HTTP format.
if {$seconds == 0} {
set seconds [clock seconds]
}
clock format $seconds -format {%a, %d %b %Y %T %Z} -gmt 1
}
proc uhttpd::Log {reason format args} {
# @c Log an httpd transaction.
set messg [eval format [list $format] $args]
set stamp [clock format [clock seconds] -format "%d/%b/%Y:%H:%M:%S"]
puts stderr "\[$stamp\] $reason: $messg"
}
proc uhttpd::Url2File {url} {
# @c Convert a url into a pathname (this is probably not right)
variable Httpd
lappend pathlist $Httpd(-root)
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 file [eval file join $pathlist]
if {[file isdirectory $file]} {
return [file join $file $Httpd(-index)]
} else {
return $file
}
}
proc uhttpd::CgiMap {data} {
# @c Decode url-encoded strings
regsub -all {\+} $data { } data
regsub -all {([][$\\])} $data {\\\1} data
regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data
return [subst $data]
}
proc uhttpd::QueryMap {query} {
# @c Decode url-encoded query into key/value pairs
set res [list]
regsub -all {[&=]} $query { } query
regsub -all { } $query { {} } query; # Othewise we lose empty values
foreach {key val} $query {
lappend res [CgiMap $key] [CgiMap $val]
}
return $res
}
proc /monitor {array} {
upvar $array data ; # Holds the socket to remote client
#
# Emit headers
#
puts $data(sock) "HTTP/1.0 200 OK"
puts $data(sock) "Date: [uhttpd::Date]"
puts $data(sock) "Content-Type: text/html"
puts $data(sock) ""
#
# Emit body
#
puts $data(sock) [subst {
<html>
<body>
<h3>[clock format [clock seconds]]</h3>
}]
after 1 ; # Simulate blocking call
puts $data(sock) [subst {
</body>
</html>
}]
}
# EOF $RCSfile: uhttpd.tcl,v $
# Emacs Setup Variables
# Local Variables:
# mode: Tcl
# indent-tabs-mode: nil
# tcl-basic-offset: 4
# End:

576
pkgs/thread2.8.7/tcl/tpool/tpool.tcl Normal file
View File

@@ -0,0 +1,576 @@
#
# tpool.tcl --
#
# Tcl implementation of a threadpool paradigm in pure Tcl using
# the Tcl threading extension 2.5 (or higher).
#
# This file is for example purposes only. The efficient C-level
# threadpool implementation is already a part of the threading
# extension starting with 2.5 version. Both implementations have
# the same Tcl API so both can be used interchangeably. Goal of
# this implementation is to serve as an example of using the Tcl
# extension to implement some very common threading paradigms.
#
# Beware: with time, as improvements are made to the C-level
# implementation, this Tcl one might lag behind.
# Please consider this code as a working example only.
#
#
#
# Copyright (c) 2002 by Zoran Vasiljevic.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -----------------------------------------------------------------------------
package require Thread 2.5
set thisScript [info script]
namespace eval tpool {
variable afterevent "" ; # Idle timer event for worker threads
variable result ; # Stores result from the worker thread
variable waiter ; # Waits for an idle worker thread
variable jobsdone ; # Accumulates results from worker threads
#
# Create shared array with a single element.
# It is used for automatic pool handles creation.
#
set ns [namespace current]
tsv::lock $ns {
if {[tsv::exists $ns count] == 0} {
tsv::set $ns count 0
}
tsv::set $ns count -1
}
variable thisScript [info script]
}
#
# tpool::create --
#
# Creates instance of a thread pool.
#
# Arguments:
# args Variable number of key/value arguments, as follows:
#
# -minworkers minimum # of worker threads (def:0)
# -maxworkers maximum # of worker threads (def:4)
# -idletime # of sec worker is idle before exiting (def:0 = never)
# -initcmd script used to initialize new worker thread
# -exitcmd script run at worker thread exit
#
# Side Effects:
# Might create many new threads if "-minworkers" option is > 0.
#
# Results:
# The id of the newly created thread pool. This id must be used
# in all other tpool::* commands.
#
proc tpool::create {args} {
variable thisScript
#
# Get next threadpool handle and create the pool array.
#
set usage "wrong \# args: should be \"[lindex [info level 1] 0]\
?-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
}
#
# Setup default pool data.
#
tsv::array set $tpid {
thrworkers ""
thrwaiters ""
jobcounter 0
refcounter 0
numworkers 0
-minworkers 0
-maxworkers 4
-idletime 0
-initcmd ""
-exitcmd ""
}
tsv::set $tpid -initcmd "source $thisScript"
#
# Override with user-supplied data
#
if {[llength $args] % 2} {
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
}
}
}
#
# Start initial (minimum) number of worker threads.
#
for {set ii 0} {$ii < [tsv::set $tpid -minworkers]} {incr ii} {
Worker $tpid
}
return $tpid
}
#
# tpool::names --
#
# Returns list of currently created threadpools
#
# Arguments:
# None.
#
# Side Effects:
# None.
#
# Results
# List of active threadpoool identifiers or empty if none found
#
#
proc tpool::names {} {
tsv::names [namespace tail [namespace current]]*
}
#
# tpool::post --
#
# Submits the new job to the thread pool. The caller might pass
# the job in two modes: synchronous and asynchronous.
# For the synchronous mode, the pool implementation will retain
# the result of the passed script until the caller collects it
# using the "thread::get" command.
# For the asynchronous mode, the result of the script is ignored.
#
# Arguments:
# args Variable # of arguments with the following syntax:
# tpool::post ?-detached? tpid script
#
# -detached flag to turn the async operation (ignore result)
# tpid the id of the thread pool
# script script to pass to the worker thread for execution
#
# Side Effects:
# Depends on the passed script.
#
# Results:
# The id of the posted job. This id is used later on to collect
# result of the job and set local variables accordingly.
# For asynchronously posted jobs, the return result is ignored
# and this function returns empty result.
#
proc tpool::post {args} {
#
# Parse command arguments.
#
set ns [namespace current]
set usage "wrong \# args: should be \"[lindex [info level 1] 0]\
?-detached? tpoolId script\""
if {[llength $args] == 2} {
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]
} else {
error $usage
}
#
# Find idle (or create new) worker thread. This is relatively
# a complex issue, since we must honour the limits about number
# of allowed worker threads imposed to us by the caller.
#
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
}
}
#
# Post the command to the worker thread
#
if {$detached} {
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
}
variable jobsdone
set jobsdone($j) ""
return $j
}
#
# tpool::wait --
#
# Waits for jobs sent with "thread::post" to finish.
#
# Arguments:
# tpid Name of the pool shared array.
# jobList List of job id's done.
# jobLeft List of jobs still pending.
#
# Side Effects:
# Might eventually enter the event loop while waiting
# for the job result to arrive from the worker thread.
# It ignores bogus job ids.
#
# Results:
# Result of the job. If the job resulted in error, it sets
# the global errorInfo and errorCode variables accordingly.
#
proc tpool::wait {tpid jobList {jobLeft ""}} {
variable result
variable jobsdone
if {$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 {[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
}
}
}
return $retlist
}
#
# tpool::get --
#
# Waits for a job sent with "thread::post" to finish.
#
# Arguments:
# tpid Name of the pool shared array.
# jobid Id of the previously posted job.
#
# Side Effects:
# None.
#
# Results:
# Result of the job. If the job resulted in error, it sets
# the global errorInfo and errorCode variables accordingly.
#
proc tpool::get {tpid jobid} {
variable jobsdone
if {[lindex $jobsdone($jobid) 1] != 0} {
eval error [lrange $jobsdone($jobid) 2 end]
}
return [lindex $jobsdone($jobid) 2]
}
#
# tpool::preserve --
#
# Increments the reference counter of the threadpool, reserving it
# for the private usage..
#
# Arguments:
# tpid Name of the pool shared array.
#
# Side Effects:
# None.
#
# Results:
# Current number of threadpool reservations.
#
proc tpool::preserve {tpid} {
tsv::incr $tpid refcounter
}
#
# tpool::release --
#
# Decrements the reference counter of the threadpool, eventually
# tearing the pool down if this was the last reservation.
#
# Arguments:
# tpid Name of the pool shared array.
#
# Side Effects:
# If the number of reservations drops to zero or below
# the threadpool is teared down.
#
# Results:
# Current number of threadpool reservations.
#
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!
}
}
}
#
# Private procedures, not a part of the threadpool API.
#
#
# tpool::Worker --
#
# Creates new worker thread. This procedure must be executed
# under the tsv lock.
#
# Arguments:
# tpid Name of the pool shared array.
#
# Side Effects:
# Depends on the thread initialization script.
#
# Results:
# None.
#
proc tpool::Worker {tpid} {
#
# Create new worker thread
#
set tid [thread::create]
thread::send $tid [tsv::set $tpid -initcmd]
thread::preserve $tid
tsv::incr $tpid numworkers
tsv::lpush $tpid thrworkers $tid
#
# Signalize waiter threads if any
#
set waiter [tsv::lpop $tpid thrwaiters]
if {$waiter != ""} {
thread::send -async $waiter [subst {
set [namespace current]::waiter 1
}]
}
}
#
# tpool::Timer --
#
# This procedure should be executed within the worker thread only.
# It registers the callback for terminating the idle thread.
#
# Arguments:
# tpid Name of the pool shared array.
#
# Side Effects:
# Thread may eventually exit.
#
# Results:
# None.
#
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
}
}
}
}
#
# tpool::Run --
#
# This procedure should be executed within the worker thread only.
# It performs the actual command execution in the worker thread.
#
# Arguments:
# tpid Name of the pool shared array.
# jid The job id
# cmd The command to execute
#
# Side Effects:
# Many, depending of the passed command
#
# Results:
# List for passing the evaluation result and status back.
#
proc tpool::Run {tpid jid cmd} {
#
# Cancel the idle timer callback, if any.
#
variable afterevent
if {$afterevent != ""} {
after cancel $afterevent
}
#
# Evaluate passed command and build the result list.
#
set code [catch {uplevel \#0 $cmd} ret]
if {$code == 0} {
set res [list $jid 0 $ret]
} else {
set res [list $jid $code $ret $::errorInfo $::errorCode]
}
#
# Check to see if any caller is waiting to be serviced.
# If yes, kick it out of the waiting state.
#
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
}]
}
}
#
# Release the thread. If this turns out to be
# the last refcount held, don't bother to do
# any more work, since thread will soon exit.
#
if {[thread::release] <= 0} {
return $res
}
#
# Register the idle timer again.
#
if {[set idle [tsv::set $tpid -idletime]]} {
set afterevent [after $idle [subst {
${ns}::Timer $tpid
}]]
}
return $res
}
# EOF $RCSfile: tpool.tcl,v $
# Emacs Setup Variables
# Local Variables:
# mode: Tcl
# indent-tabs-mode: nil
# tcl-basic-offset: 4
# End:

26
pkgs/thread2.8.7/tclconfig/README.txt Normal file
View File

@@ -0,0 +1,26 @@
These files comprise the basic building blocks for a Tcl Extension
Architecture (TEA) extension. For more information on TEA see:
http://www.tcl.tk/doc/tea/
This package is part of the Tcl project at SourceForge, but sources
and bug/patch database are hosted on fossil here:
https://core.tcl-lang.org/tclconfig
This package is a freely available open source package. You can do
virtually anything you like with it, such as modifying it, redistributing
it, and selling it either in whole or in part.
CONTENTS
========
The following is a short description of the files you will find in
the sample extension.
README.txt This file
install-sh Program used for copying binaries and script files
to their install locations.
tcl.m4 Collection of Tcl autoconf macros. Included by a package's
aclocal.m4 to define TEA_* macros.

518
pkgs/thread2.8.7/tclconfig/install-sh Normal file
View File

@@ -0,0 +1,518 @@
#!/bin/sh
# install - install a program, script, or datafile
scriptversion=2020-07-26.22; # UTC
# This originates from X11R5 (mit/util/scripts/install.sh), which was
# later released in X11R6 (xc/config/util/install.sh) with the
# following copyright and license.
#
# Copyright (C) 1994 X Consortium
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN
# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC-
# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
#
# Except as contained in this notice, the name of the X Consortium shall not
# be used in advertising or otherwise to promote the sale, use or other deal-
# ings in this Software without prior written authorization from the X Consor-
# tium.
#
#
# FSF changes to this file are in the public domain.
#
# Calling this script install-sh is preferred over install.sh, to prevent
# 'make' implicit rules from creating a file called install from it
# when there is no Makefile.
#
# This script is compatible with the BSD install script, but was written
# from scratch.
tab=' '
nl='
'
IFS=" $tab$nl"
# Set DOITPROG to "echo" to test this script.
doit=${DOITPROG-}
doit_exec=${doit:-exec}
# Put in absolute file names if you don't have them in your path;
# or use environment vars.
chgrpprog=${CHGRPPROG-chgrp}
chmodprog=${CHMODPROG-chmod}
chownprog=${CHOWNPROG-chown}
cmpprog=${CMPPROG-cmp}
cpprog=${CPPROG-cp}
mkdirprog=${MKDIRPROG-mkdir}
mvprog=${MVPROG-mv}
rmprog=${RMPROG-rm}
stripprog=${STRIPPROG-strip}
posix_mkdir=
# Desired mode of installed file.
mode=0755
# Create dirs (including intermediate dirs) using mode 755.
# This is like GNU 'install' as of coreutils 8.32 (2020).
mkdir_umask=22
chgrpcmd=
chmodcmd=$chmodprog
chowncmd=
mvcmd=$mvprog
rmcmd="$rmprog -f"
stripcmd=
src=
dst=
dir_arg=
dst_arg=
copy_on_change=false
is_target_a_directory=possibly
usage="\
Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE
or: $0 [OPTION]... SRCFILES... DIRECTORY
or: $0 [OPTION]... -t DIRECTORY SRCFILES...
or: $0 [OPTION]... -d DIRECTORIES...
In the 1st form, copy SRCFILE to DSTFILE.
In the 2nd and 3rd, copy all SRCFILES to DIRECTORY.
In the 4th, create DIRECTORIES.
Options:
--help display this help and exit.
--version display version info and exit.
-c (ignored)
-C install only if different (preserve the last data modification time)
-d create directories instead of installing files.
-g GROUP $chgrpprog installed files to GROUP.
-m MODE $chmodprog installed files to MODE.
-o USER $chownprog installed files to USER.
-s $stripprog installed files.
-S OPTION $stripprog installed files using OPTION.
-t DIRECTORY install into DIRECTORY.
-T report an error if DSTFILE is a directory.
Environment variables override the default commands:
CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG
RMPROG STRIPPROG
"
while test $# -ne 0; do
case $1 in
-c) ;;
-C) copy_on_change=true;;
-d) dir_arg=true;;
-g) chgrpcmd="$chgrpprog $2"
shift;;
--help) echo "$usage"; exit $?;;
-m) mode=$2
case $mode in
*' '* | *"$tab"* | *"$nl"* | *'*'* | *'?'* | *'['*)
echo "$0: invalid mode: $mode" >&2
exit 1;;
esac
shift;;
-o) chowncmd="$chownprog $2"
shift;;
-s) stripcmd=$stripprog;;
-S) stripcmd="$stripprog $2"
shift;;
-t)
is_target_a_directory=always
dst_arg=$2
# Protect names problematic for 'test' and other utilities.
case $dst_arg in
-* | [=\(\)!]) dst_arg=./$dst_arg;;
esac
shift;;
-T) is_target_a_directory=never;;
--version) echo "$0 $scriptversion"; exit $?;;
--) shift
break;;
-*) echo "$0: invalid option: $1" >&2
exit 1;;
*) break;;
esac
shift
done
# We allow the use of options -d and -T together, by making -d
# take the precedence; this is for compatibility with GNU install.
if test -n "$dir_arg"; then
if test -n "$dst_arg"; then
echo "$0: target directory not allowed when installing a directory." >&2
exit 1
fi
fi
if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then
# When -d is used, all remaining arguments are directories to create.
# When -t is used, the destination is already specified.
# Otherwise, the last argument is the destination. Remove it from $@.
for arg
do
if test -n "$dst_arg"; then
# $@ is not empty: it contains at least $arg.
set fnord "$@" "$dst_arg"
shift # fnord
fi
shift # arg
dst_arg=$arg
# Protect names problematic for 'test' and other utilities.
case $dst_arg in
-* | [=\(\)!]) dst_arg=./$dst_arg;;
esac
done
fi
if test $# -eq 0; then
if test -z "$dir_arg"; then
echo "$0: no input file specified." >&2
exit 1
fi
# It's OK to call 'install-sh -d' without argument.
# This can happen when creating conditional directories.
exit 0
fi
if test -z "$dir_arg"; then
if test $# -gt 1 || test "$is_target_a_directory" = always; then
if test ! -d "$dst_arg"; then
echo "$0: $dst_arg: Is not a directory." >&2
exit 1
fi
fi
fi
if test -z "$dir_arg"; then
do_exit='(exit $ret); exit $ret'
trap "ret=129; $do_exit" 1
trap "ret=130; $do_exit" 2
trap "ret=141; $do_exit" 13
trap "ret=143; $do_exit" 15
# Set umask so as not to create temps with too-generous modes.
# However, 'strip' requires both read and write access to temps.
case $mode in
# Optimize common cases.
*644) cp_umask=133;;
*755) cp_umask=22;;
*[0-7])
if test -z "$stripcmd"; then
u_plus_rw=
else
u_plus_rw='% 200'
fi
cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;;
*)
if test -z "$stripcmd"; then
u_plus_rw=
else
u_plus_rw=,u+rw
fi
cp_umask=$mode$u_plus_rw;;
esac
fi
for src
do
# Protect names problematic for 'test' and other utilities.
case $src in
-* | [=\(\)!]) src=./$src;;
esac
if test -n "$dir_arg"; then
dst=$src
dstdir=$dst
test -d "$dstdir"
dstdir_status=$?
else
# Waiting for this to be detected by the "$cpprog $src $dsttmp" command
# might cause directories to be created, which would be especially bad
# if $src (and thus $dsttmp) contains '*'.
if test ! -f "$src" && test ! -d "$src"; then
echo "$0: $src does not exist." >&2
exit 1
fi
if test -z "$dst_arg"; then
echo "$0: no destination specified." >&2
exit 1
fi
dst=$dst_arg
# If destination is a directory, append the input filename.
if test -d "$dst"; then
if test "$is_target_a_directory" = never; then
echo "$0: $dst_arg: Is a directory" >&2
exit 1
fi
dstdir=$dst
dstbase=`basename "$src"`
case $dst in
*/) dst=$dst$dstbase;;
*) dst=$dst/$dstbase;;
esac
dstdir_status=0
else
dstdir=`dirname "$dst"`
test -d "$dstdir"
dstdir_status=$?
fi
fi
case $dstdir in
*/) dstdirslash=$dstdir;;
*) dstdirslash=$dstdir/;;
esac
obsolete_mkdir_used=false
if test $dstdir_status != 0; then
case $posix_mkdir in
'')
# With -d, create the new directory with the user-specified mode.
# Otherwise, rely on $mkdir_umask.
if test -n "$dir_arg"; then
mkdir_mode=-m$mode
else
mkdir_mode=
fi
posix_mkdir=false
# The $RANDOM variable is not portable (e.g., dash). Use it
# here however when possible just to lower collision chance.
tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$
trap '
ret=$?
rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" 2>/dev/null
exit $ret
' 0
# Because "mkdir -p" follows existing symlinks and we likely work
# directly in world-writeable /tmp, make sure that the '$tmpdir'
# directory is successfully created first before we actually test
# 'mkdir -p'.
if (umask $mkdir_umask &&
$mkdirprog $mkdir_mode "$tmpdir" &&
exec $mkdirprog $mkdir_mode -p -- "$tmpdir/a/b") >/dev/null 2>&1
then
if test -z "$dir_arg" || {
# Check for POSIX incompatibilities with -m.
# HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or
# other-writable bit of parent directory when it shouldn't.
# FreeBSD 6.1 mkdir -m -p sets mode of existing directory.
test_tmpdir="$tmpdir/a"
ls_ld_tmpdir=`ls -ld "$test_tmpdir"`
case $ls_ld_tmpdir in
d????-?r-*) different_mode=700;;
d????-?--*) different_mode=755;;
*) false;;
esac &&
$mkdirprog -m$different_mode -p -- "$test_tmpdir" && {
ls_ld_tmpdir_1=`ls -ld "$test_tmpdir"`
test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1"
}
}
then posix_mkdir=:
fi
rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir"
else
# Remove any dirs left behind by ancient mkdir implementations.
rmdir ./$mkdir_mode ./-p ./-- "$tmpdir" 2>/dev/null
fi
trap '' 0;;
esac
if
$posix_mkdir && (
umask $mkdir_umask &&
$doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir"
)
then :
else
# mkdir does not conform to POSIX,
# or it failed possibly due to a race condition. Create the
# directory the slow way, step by step, checking for races as we go.
case $dstdir in
/*) prefix='/';;
[-=\(\)!]*) prefix='./';;
*) prefix='';;
esac
oIFS=$IFS
IFS=/
set -f
set fnord $dstdir
shift
set +f
IFS=$oIFS
prefixes=
for d
do
test X"$d" = X && continue
prefix=$prefix$d
if test -d "$prefix"; then
prefixes=
else
if $posix_mkdir; then
(umask $mkdir_umask &&
$doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break
# Don't fail if two instances are running concurrently.
test -d "$prefix" || exit 1
else
case $prefix in
*\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;;
*) qprefix=$prefix;;
esac
prefixes="$prefixes '$qprefix'"
fi
fi
prefix=$prefix/
done
if test -n "$prefixes"; then
# Don't fail if two instances are running concurrently.
(umask $mkdir_umask &&
eval "\$doit_exec \$mkdirprog $prefixes") ||
test -d "$dstdir" || exit 1
obsolete_mkdir_used=true
fi
fi
fi
if test -n "$dir_arg"; then
{ test -z "$chowncmd" || $doit $chowncmd "$dst"; } &&
{ test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } &&
{ test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false ||
test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1
else
# Make a couple of temp file names in the proper directory.
dsttmp=${dstdirslash}_inst.$$_
rmtmp=${dstdirslash}_rm.$$_
# Trap to clean up those temp files at exit.
trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0
# Copy the file name to the temp name.
(umask $cp_umask &&
{ test -z "$stripcmd" || {
# Create $dsttmp read-write so that cp doesn't create it read-only,
# which would cause strip to fail.
if test -z "$doit"; then
: >"$dsttmp" # No need to fork-exec 'touch'.
else
$doit touch "$dsttmp"
fi
}
} &&
$doit_exec $cpprog "$src" "$dsttmp") &&
# and set any options; do chmod last to preserve setuid bits.
#
# If any of these fail, we abort the whole thing. If we want to
# ignore errors from any of these, just make sure not to ignore
# errors from the above "$doit $cpprog $src $dsttmp" command.
#
{ test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } &&
{ test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } &&
{ test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } &&
{ test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } &&
# If -C, don't bother to copy if it wouldn't change the file.
if $copy_on_change &&
old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` &&
new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` &&
set -f &&
set X $old && old=:$2:$4:$5:$6 &&
set X $new && new=:$2:$4:$5:$6 &&
set +f &&
test "$old" = "$new" &&
$cmpprog "$dst" "$dsttmp" >/dev/null 2>&1
then
rm -f "$dsttmp"
else
# Rename the file to the real destination.
$doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null ||
# The rename failed, perhaps because mv can't rename something else
# to itself, or perhaps because mv is so ancient that it does not
# support -f.
{
# Now remove or move aside any old file at destination location.
# We try this two ways since rm can't unlink itself on some
# systems and the destination file might be busy for other
# reasons. In this case, the final cleanup might fail but the new
# file should still install successfully.
{
test ! -f "$dst" ||
$doit $rmcmd -f "$dst" 2>/dev/null ||
{ $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null &&
{ $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; }
} ||
{ echo "$0: cannot unlink or rename $dst" >&2
(exit 1); exit 1
}
} &&
# Now rename the file to the real destination.
$doit $mvcmd "$dsttmp" "$dst"
}
fi || exit 1
trap '' 0
fi
done
# Local variables:
# eval: (add-hook 'before-save-hook 'time-stamp)
# time-stamp-start: "scriptversion="
# time-stamp-format: "%:y-%02m-%02d.%02H"
# time-stamp-time-zone: "UTC0"
# time-stamp-end: "; # UTC"
# End:

4055
pkgs/thread2.8.7/tclconfig/tcl.m4 Normal file
View File

File diff suppressed because it is too large Load Diff

3257
pkgs/thread2.8.7/tests/French.txt Normal file
View File

File diff suppressed because it is too large Load Diff

59
pkgs/thread2.8.7/tests/all.tcl Normal file
View File

@@ -0,0 +1,59 @@
# all.tcl --
#
# This file contains a top-level script to run all of the Tcl
# tests. Execute it by invoking "source all.test" when running tcltest
# in this directory.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest
::tcltest::loadTestedCommands
package require Thread
set ::tcltest::testSingleFile false
set ::tcltest::testsDirectory [file dir [info script]]
# We need to ensure that the testsDirectory is absolute
::tcltest::normalizePath ::tcltest::testsDirectory
puts stdout "Tcl $tcl_patchLevel tests running in interp: [info nameofexecutable]"
puts stdout "Tests running in working dir: $::tcltest::testsDirectory"
if {[llength $::tcltest::skip] > 0} {
puts stdout "Skipping tests that match: $::tcltest::skip"
}
if {[llength $::tcltest::match] > 0} {
puts stdout "Only running tests that match: $::tcltest::match"
}
if {[llength $::tcltest::skipFiles] > 0} {
puts stdout "Skipping test files that match: $::tcltest::skipFiles"
}
if {[llength $::tcltest::matchFiles] > 0} {
puts stdout "Only sourcing test files that match: $::tcltest::matchFiles"
}
set timeCmd {clock format [clock seconds]}
puts stdout "Tests began at [eval $timeCmd]"
# These tests need to know which is the main thread
set ::tcltest::mainThread [thread::id]
puts stdout "Thread [package provide Thread]"
puts stdout "Mainthread id is $::tcltest::mainThread"
# Source each of the specified tests
foreach file [lsort [::tcltest::getMatchingFiles]] {
set tail [file tail $file]
puts stdout $tail
if {[catch {source $file} msg]} {
puts stdout $msg
}
}
# Cleanup
puts stdout "\nTests ended at [eval $timeCmd]"
::tcltest::cleanupTests 1
return

70
pkgs/thread2.8.7/tests/store-load.tcl Normal file
View File

@@ -0,0 +1,70 @@
#!/usr/bin/env tclsh
lappend auto_path .
package require Thread
if {[llength $argv] != 3} {
puts "Usage: $argv0 handle path times"
puts {
handle
A persistent storage handle (see [tsv::array bind] manpage).
path
The path to file containing lines in the form of "key<tab>val", where
key is a single-word and val is everyting else.
times
The number of times to reload the data from persistent storage.
This script reads lines of data from <path> and stores them into the
persistent storage described by <handle>. Values for duplicate keys are
handled as a lists. The persistent storage engine is then stress-tested by
reloading the whole store <times> times.
}
exit 1
}
lassign $argv handle path times
### Cleanup
set filename [string range $handle [string first : $handle]+1 end]
file delete -force $filename
### Load and store tab-separated values
tsv::array bind a $handle
set fd [open $path r]
set start [clock milliseconds]
set pairs 0
while {[gets $fd line] > 0} {
if {[string index $line 0] eq {#}} {
continue
}
set tab [string first { } $line]
if {$tab == -1} {
continue
}
set k [string range $line 0 $tab-1]
set v [string range $line $tab+1 end]
if {![tsv::exists a $k]} {
incr pairs
}
tsv::lappend a $k $v
}
puts "Stored $pairs pairs in [expr {[clock milliseconds]-$start}] milliseconds"
tsv::array unbind a
tsv::unset a
### Reload
set pairs 0
set iter [time {
tsv::array bind a $handle
set pairs [tsv::array size a]
tsv::array unbind a
tsv::unset a
} $times]
puts "Loaded $pairs pairs $times times at $iter"
## Dump file stats
puts "File $filename is [file size $filename] bytes long"

1201
pkgs/thread2.8.7/tests/thread.test Normal file
View File

File diff suppressed because it is too large Load Diff

25
pkgs/thread2.8.7/tests/tkt-84be1b5a73.test Normal file
View File

@@ -0,0 +1,25 @@
package require tcltest
namespace import ::tcltest::*
tcltest::loadTestedCommands
package require Thread
# This test used to segfault before commit f4c95731c0.
test tkt-84be1b5a73 {Ticket 84be1b5a73} -body {
set t [thread::create]
set resultvar() {}
trace add variable resultvar() write {
unset -nocomplain resultvar()
list}
proc errorproc {tid einfo} {}
thread::errorproc errorproc
thread::send -async $t {
error ""
} resultvar()
after 1000 {
set forever 1
}
vwait forever
} -returnCodes 0

1
pkgs/thread2.8.7/tests/tpool.test Normal file
View File

@@ -0,0 +1 @@
return

107
pkgs/thread2.8.7/tests/tsv.test Normal file
View File

@@ -0,0 +1,107 @@
package require tcltest
namespace import ::tcltest::*
tcltest::loadTestedCommands
package require Thread
set backends {gdbm lmdb}
foreach b $backends {
testConstraint have_$b [expr {$b in [tsv::handlers]}]
}
foreach backend $backends {
set db "data"
file delete -force $db
set ::handle $backend:$db
proc setup {} {
tsv::array bind a $::handle
}
proc cleanup {} {
tsv::array unbind a
}
test tsv-$backend-1.0 {tsv::array isboud} \
-constraints have_$backend \
-setup {
setup
} -body {
tsv::array isbound a
} -cleanup {
cleanup
} -result {1}
test tsv-$backend-1.1 {tsv::array bind - empty} \
-constraints have_$backend \
-setup {
setup
} -body {
tsv::array names b
} -cleanup {
cleanup
} -result {}
test tsv-$backend-1.2 {tsv::set} \
-constraints have_$backend \
-setup {
setup
} -body {
tsv::set a Key Val
} -cleanup {
cleanup
} -result {Val}
test tsv-$backend-1.3 {tsv::get - previously set was persisted} \
-constraints have_$backend \
-setup {
setup
} -body {
tsv::get a Key
} -cleanup {
cleanup
} -result {Val}
test tsv-$backend-1.4 {tsv::array names - previously set was persisted} \
-constraints have_$backend \
-setup {
setup
} -body {
tsv::array names a
} -cleanup {
cleanup
} -result {Key}
test tsv-$backend-1.5 {tsv::exists - previously set exists} \
-constraints have_$backend \
-setup {
setup
} -body {
tsv::exists a Key
} -cleanup {
cleanup
} -result {1}
test tsv-$backend-1.6 {tsv::pop - get previously set} \
-constraints have_$backend \
-setup {
setup
} -body {
tsv::pop a Key
} -cleanup {
cleanup
} -result {Val}
test tsv-$backend-1.7 {tsv::exists - popped was removed} \
-constraints have_$backend \
-setup {
setup
} -body {
tsv::exists a Key
} -cleanup {
cleanup
} -result {0}
file delete -force $db
}
::tcltest::cleanupTests

1
pkgs/thread2.8.7/tests/ttrace.test Normal file
View File

@@ -0,0 +1 @@
return

53
pkgs/thread2.8.7/unix/CONFIG Normal file
View File

@@ -0,0 +1,53 @@
#!/bin/sh
#
# This file contains collection of configure directives
# for building the Threading extension.
#
# Comment-out next line if building with GCC compiler.
#
# CC=gcc; export CC
#
#
# Tcl on Unix (uses public Tcl library)
# ----------------------------------------------------
# ../configure --enable-threads
#
# As of 2.6, the threading extension supports persistent
# shared variables. As an working example of this, there
# is a simple wrapper for the popular Gdbm library.
# Uncomment the following line if you like to compile the
# Gdbm wrapper for persistent shared variables.
#
# ../configure --enable-threads --with-gdbm
#
# If your Gdbm library is not installed in one of the
# default system locations (/usr/lib, /usr/local/lib ...)
# please use following directive. Note that both library
# file *and* includes should be located in "/my/gdbm".
# Of course, you have to replace the "/my/gdbm" below
# with the exact location, as found in your system:
#
# ../configure --enable-threads --with-gdbm=/my/gdbm
#
#
# AOLserver 4.X; Uses public Tcl library.
# ----------------------------------------------------
# nsdir="/usr/local/naviserver"
# ../configure --enable-threads \
# --with-naviserver=$nsdir \
# --prefix=$nsdir --exec-prefix=$nsdir
#
# NaviServer/AOLserver uses its own package loading mechanism.
# To load, just do "ns_eval package require Thread"
# at the NaviServer/AOLserver startup or later from any thread.
#
#
# Mac OS X; Uses public Tcl library.
# ----------------------------------------------------
# ../configure --enable-threads \
# --mandir=/usr/local/share/man \
# --libdir=/Library/Tcl \
# --with-tcl=/Library/Frameworks/Tcl.framework \
# --with-tclinclude=/Library/Frameworks/Tcl.framework/Headers
#
# EOF

70
pkgs/thread2.8.7/unix/README Normal file
View File

@@ -0,0 +1,70 @@
I. Building the Tcl thread extension for Unix
=============================================
Extension can be compiled on several Unix derivates including various
distributions of Linux. Build process is pretty straightforward. I've
checked some versions of Solaris, Linux and Darwin, but the extension
should compile without problems on any Unix-like operating system
with a proper pthreads library implementation.
To build on Unix-like operating systems, start with the CONFIG script
and see if there is already a combination of the "configure" options
which may satisfy your needs. If not, you can run the configure script
located in the root of the distribution directory with a choice of
supported options yourself. If yes, you can uncomment corresponding
lines from the CONFIG script and do:
% sh CONFIG
Either way, this will create a Makefile which you use to run "make" and
"make install".
You can use "make clean" to clean the directory from temporary compilation
files and/or "make distclean" to additionaly remove local config files.
You might want to do "make test" before doing the "make install" in order
to run the regression tests on the package.
To explore other building options, look into the CONFIG file for more
information.
Note for NaviServer/AOLserver users
------------------------
The extension can be compiled as a loadable module for the
NaviServer/AOLserver version 4.0 or higher. In order to do this,
use "--with-naviserver" configure option to specify the directory
containing the NaviServer/AOLserver distribution. The CONFIG script
has an example how to invoke configure in order to build the
extension as NaviServer/AOLserver module. Note, however, that
"make install" and "make test" targets are still not supported for
NaviServer/AOLserver builds. This will be corrected in one of
the future releases.
To fine-tune, you might also want to make the tsv::* commands replace
the NaviServer/AOLserver built-in nsv_* family of commands, since
they are API compatible and provide richer command set plus advanced
shared-object storage of shared data. Go to the generic/threadSvCmd.h
file and look at the beginning of the file for the:
/* #define NSV_COMPAT 1 */
So, uncomment the line, recompile and there you go.
II. Building optional support libraries
=======================================
As of 2.6 release, this extension supports persistent shared variables.
To use this functionality, you might need to download and compile some
other supporting libraries. Currently, there is a simple implementation
of shared variable persistency built atop of popular GNU Gdbm package.
You can obtain the latest version of the Gdbm package from the GNU
website at: http://www.gnu.org/software/gdbm/gdbm.html
To compile with GNU Gdbm support you must configure with --with-gdbm
switch. This option, if used, will try to locate the Gdbm library on
your system at couple of standard locations. You might override this
behaviour by giving --with-gdbm=/some/dir. Note that both library file
and the include file must then reside in this directory.
-EOF-

27
pkgs/thread2.8.7/unix/threadUnix.c Normal file
View File

@@ -0,0 +1,27 @@
/*
* threadUnix.c --
*
* Unix specific aspects for the thread extension.
*
* see http://dev.activestate.com/doc/howto/thread_model.html
*
* Some of this code is based on work done by Richard Hipp on behalf of
* Conservation Through Innovation, Limited, with their permission.
*
* Copyright (c) 1998 by Sun Microsystems, Inc.
* Copyright (c) 1999,2000 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "../generic/tclThread.h"
/* EOF $RCSfile: threadUnix.c,v $ */
/* Emacs Setup Variables */
/* Local Variables: */
/* mode: C */
/* indent-tabs-mode: nil */
/* c-basic-offset: 4 */
/* End: */

21
pkgs/thread2.8.7/win/CONFIG Normal file
View File

@@ -0,0 +1,21 @@
#
# This is how I run configure. You'll want to change the
# pathnames to match your system, of course.
#
# Remember that if you use the --enable-sybols, you need to
# use the thread25d.dll in a tclsh that has also been compiled
# with symbols (e.g., tclsh84g.exe or tclsh84d.exe).
# If you want to build both debug and non-debug versions, then
# create "debug" and "release" directories and run configure
# from in those directories with the appropriate flags.
#
# Note the CC=gcc must be set *before* the "configure" is ran.
# This is really needed, otherwise configure will not be able
# to compile the small test file which checks the presence
# of the MinGW build environment. It is *not* enough to use
# "--enable-gcc" configure option; you *need* to define CC.
#
export CC=gcc
sh ../configure --enable-threads --with-tcl=e:/tcl/win

67
pkgs/thread2.8.7/win/README.txt Normal file
View File

@@ -0,0 +1,67 @@
I. Building the Tcl thread extension for Windows
================================================
Thread extension supports two build options:
o. MinGW builds:
----------------
The extension can be compiled under Windows using the
MinGW (http://www.mingw.org) environment. You can also
download the ready-to-go copy of the MinGW from the
same place you've downloaded this extension.
You should compile the Tcl core with MinGW first. After
that, you can compile the extension by running the
configure/make from this directory. You can also use the
CONFIG script to do this. You might want to edit the
script to match your environment and then just do:
sh CONFIG
This should go smoothly, once you got Tcl core compiled ok.
o. Microsoft MSVC++ build:
--------------------------
Files in this directory may be useful if you have not set up
your TEA (i.e., MinGW) environment and you're using the MSVC++
from Micro$oft.
To build the extension invoke the following command:
nmake -f makefile.vc INSTALLDIR=<path-to-installed-tcl>
INSTALLDIR is the path of the Tcl distribution where
tcl.h and other needed Tcl files are installed.
To build against a Tcl source build instead,
nmake -f makefile.vc TCLDIR=<path-to-tcl-sources>
Please look into the makefile.vc file for more options etc.
Alternatively, you can open the extension workspace and project files
(thread_win.dsw and thread_win.dsp) from within the MSVC++ and press
the F7 key to build the extension under the control of the MSVC IDE.
NOTE: it is likely that the .dsw and .dsp files are out of date. At
least Visual Studio 2017 was not able to open those files.
II. Building optional support libraries
=======================================
As of 2.6 release, this extension supports persistent shared
variables. To use this functionality, you might need to download
and compile some other supporting libraries. Currently, there is
a simple implementation of shared variable persistency built atop
of popular GNU Gdbm package. You can obtain the latest version of
the Gdbm from: http://www.gnu.org/software/gdbm/gdbm.html.
For the impatient, there are Windows ports of GNU Gdbm found on
various places on the Internet. The easiest way to start is to go
to the GnuWin32 project: http://sourceforge.net/projects/gnuwin32
and fetch yourself a compiled GNU Gdbm DLL.
-EOF-

66
pkgs/thread2.8.7/win/makefile.vc Normal file
View File

@@ -0,0 +1,66 @@
#------------------------------------------------------------- -*- makefile -*-
#
# Makefile for thread extension
#
# Basic build, test and install
# nmake /f makefile.vc INSTALLDIR=c:\tcl
# nmake /f makefile.vc INSTALLDIR=c:\tcl test
# nmake /f makefile.vc INSTALLDIR=c:\tcl install
#
# For other build options (debug, static etc.),
# See TIP 477 (https://core.tcl.tk/tips/doc/main/tip/477.md) for
# detailed documentation.
#
# In addition to the command line macros described there the following
# may also be defined.
# ADDOPTDEFINES - addition compiler options
# ADDLINKOPTS - addition link options
# E.g.
# nmake -nologo -f makefile.vc TCLDIR=%TCLDIR% ... ADDOPTDEFINES="-I%LMDBDIR%" ADDLINKOPTS="%LMDBDIR%\Release\lmdb.lib"
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#------------------------------------------------------------------------------
PROJECT = thread
RCFILE = thread.rc
DOCDIR = $(ROOT)\doc\html
PRJ_DEFINES = -D _CRT_SECURE_NO_DEPRECATE -D _CRT_NONSTDC_NO_DEPRECATE -D_CRT_SECURE_NO_WARNINGS
PRJ_DEFINES = $(PRJ_DEFINES) -DTCL_TIP143 -DTCL_TIP285 -DTCL_NO_DEPRECATED=1 $(ADDOPTDEFINES)
PRJ_LIBS = $(ADDLINKOPTS)
!include "rules-ext.vc"
PRJ_OBJS = \
$(TMP_DIR)\threadNs.obj \
$(TMP_DIR)\threadCmd.obj \
$(TMP_DIR)\threadSvCmd.obj \
$(TMP_DIR)\threadSpCmd.obj \
$(TMP_DIR)\threadPoolCmd.obj \
$(TMP_DIR)\psGdbm.obj \
$(TMP_DIR)\psLmdb.obj \
$(TMP_DIR)\threadSvListCmd.obj \
$(TMP_DIR)\threadSvKeylistCmd.obj \
$(TMP_DIR)\tclXkeylist.obj
!include "$(_RULESDIR)\targets.vc"
install: default-install-docs-html
pkgindex: default-pkgindex-tea
$(ROOT)\manifest.uuid:
copy $(WIN_DIR)\gitmanifest.in $(ROOT)\manifest.uuid
git rev-parse HEAD >>$(ROOT)\manifest.uuid
# Explicit dependency rules
$(GENERICDIR)\psGdbm.c: $(GENERICDIR)\psGdbm.h
$(GENERICDIR)\psLmdb.c: $(GENERICDIR)\psLmdb.h
$(GENERICDIR)\threadCmd.c : $(GENERICDIR)\tclThreadInt.h
$(GENERICDIR)\threadSpCmd.c : $(GENERICDIR)\tclThreadInt.h
$(GENERICDIR)\threadSvCmd.c : $(GENERICDIR)\tclThreadInt.h
$(GENERICDIR)\threadPoolCmd.c : $(GENERICDIR)\tclThreadInt.h
$(GENERICDIR)\threadSvListCmd.c : $(GENERICDIR)\tclThreadInt.h
$(GENERICDIR)\threadSvKeylistCmd.c : $(GENERICDIR)\tclThreadInt.h

815
pkgs/thread2.8.7/win/nmakehlp.c Normal file
View File

@@ -0,0 +1,815 @@
/*
* ----------------------------------------------------------------------------
* nmakehlp.c --
*
* This is used to fix limitations within nmake and the environment.
*
* Copyright (c) 2002 by David Gravereaux.
* Copyright (c) 2006 by Pat Thoyts
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
* ----------------------------------------------------------------------------
*/
#define _CRT_SECURE_NO_DEPRECATE
#include <windows.h>
#ifdef _MSC_VER
#pragma comment (lib, "user32.lib")
#pragma comment (lib, "kernel32.lib")
#endif
#include <stdio.h>
#include <math.h>
/*
* This library is required for x64 builds with _some_ versions of MSVC
*/
#if defined(_M_IA64) || defined(_M_AMD64)
#if _MSC_VER >= 1400 && _MSC_VER < 1500
#pragma comment(lib, "bufferoverflowU")
#endif
#endif
/* ISO hack for dumb VC++ */
#ifdef _MSC_VER
#define snprintf _snprintf
#endif
/* protos */
static int CheckForCompilerFeature(const char *option);
static int CheckForLinkerFeature(char **options, int count);
static int IsIn(const char *string, const char *substring);
static int SubstituteFile(const char *substs, const char *filename);
static int QualifyPath(const char *path);
static int LocateDependency(const char *keyfile);
static const char *GetVersionFromFile(const char *filename, const char *match, int numdots);
static DWORD WINAPI ReadFromPipe(LPVOID args);
/* globals */
#define CHUNK 25
#define STATICBUFFERSIZE 1000
typedef struct {
HANDLE pipe;
char buffer[STATICBUFFERSIZE];
} pipeinfo;
pipeinfo Out = {INVALID_HANDLE_VALUE, ""};
pipeinfo Err = {INVALID_HANDLE_VALUE, ""};
/*
* exitcodes: 0 == no, 1 == yes, 2 == error
*/
int
main(
int argc,
char *argv[])
{
char msg[300];
DWORD dwWritten;
int chars;
const char *s;
/*
* Make sure children (cl.exe and link.exe) are kept quiet.
*/
SetErrorMode(SEM_FAILCRITICALERRORS | SEM_NOOPENFILEERRORBOX);
/*
* Make sure the compiler and linker aren't effected by the outside world.
*/
SetEnvironmentVariable("CL", "");
SetEnvironmentVariable("LINK", "");
if (argc > 1 && *argv[1] == '-') {
switch (*(argv[1]+1)) {
case 'c':
if (argc != 3) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -c <compiler option>\n"
"Tests for whether cl.exe supports an option\n"
"exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
return 2;
}
return CheckForCompilerFeature(argv[2]);
case 'l':
if (argc < 3) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -l <linker option> ?<mandatory option> ...?\n"
"Tests for whether link.exe supports an option\n"
"exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
return 2;
}
return CheckForLinkerFeature(&argv[2], argc-2);
case 'f':
if (argc == 2) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -f <string> <substring>\n"
"Find a substring within another\n"
"exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
return 2;
} else if (argc == 3) {
/*
* If the string is blank, there is no match.
*/
return 0;
} else {
return IsIn(argv[2], argv[3]);
}
case 's':
if (argc == 2) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -s <substitutions file> <file>\n"
"Perform a set of string map type substutitions on a file\n"
"exitcodes: 0\n",
argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
return 2;
}
return SubstituteFile(argv[2], argv[3]);
case 'V':
if (argc != 4) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -V filename matchstring\n"
"Extract a version from a file:\n"
"eg: pkgIndex.tcl \"package ifneeded http\"",
argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
return 0;
}
s = GetVersionFromFile(argv[2], argv[3], *(argv[1]+2) - '0');
if (s && *s) {
printf("%s\n", s);
return 0;
} else
return 1; /* Version not found. Return non-0 exit code */
case 'Q':
if (argc != 3) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -Q path\n"
"Emit the fully qualified path\n"
"exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
return 2;
}
return QualifyPath(argv[2]);
case 'L':
if (argc != 3) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -L keypath\n"
"Emit the fully qualified path of directory containing keypath\n"
"exitcodes: 0 == success, 1 == not found, 2 == error\n", argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
return 2;
}
return LocateDependency(argv[2]);
}
}
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -c|-f|-l|-Q|-s|-V ...\n"
"This is a little helper app to equalize shell differences between WinNT and\n"
"Win9x and get nmake.exe to accomplish its job.\n",
argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL);
return 2;
}
static int
CheckForCompilerFeature(
const char *option)
{
STARTUPINFO si;
PROCESS_INFORMATION pi;
SECURITY_ATTRIBUTES sa;
DWORD threadID;
char msg[300];
BOOL ok;
HANDLE hProcess, h, pipeThreads[2];
char cmdline[100];
hProcess = GetCurrentProcess();
ZeroMemory(&pi, sizeof(PROCESS_INFORMATION));
ZeroMemory(&si, sizeof(STARTUPINFO));
si.cb = sizeof(STARTUPINFO);
si.dwFlags = STARTF_USESTDHANDLES;
si.hStdInput = INVALID_HANDLE_VALUE;
ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES));
sa.nLength = sizeof(SECURITY_ATTRIBUTES);
sa.lpSecurityDescriptor = NULL;
sa.bInheritHandle = FALSE;
/*
* Create a non-inheritible pipe.
*/
CreatePipe(&Out.pipe, &h, &sa, 0);
/*
* Dupe the write side, make it inheritible, and close the original.
*/
DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput, 0, TRUE,
DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
/*
* Same as above, but for the error side.
*/
CreatePipe(&Err.pipe, &h, &sa, 0);
DuplicateHandle(hProcess, h, hProcess, &si.hStdError, 0, TRUE,
DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
/*
* Base command line.
*/
lstrcpy(cmdline, "cl.exe -nologo -c -TC -Zs -X -Fp.\\_junk.pch ");
/*
* Append our option for testing
*/
lstrcat(cmdline, option);
/*
* Filename to compile, which exists, but is nothing and empty.
*/
lstrcat(cmdline, " .\\nul");
ok = CreateProcess(
NULL, /* Module name. */
cmdline, /* Command line. */
NULL, /* Process handle not inheritable. */
NULL, /* Thread handle not inheritable. */
TRUE, /* yes, inherit handles. */
DETACHED_PROCESS, /* No console for you. */
NULL, /* Use parent's environment block. */
NULL, /* Use parent's starting directory. */
&si, /* Pointer to STARTUPINFO structure. */
&pi); /* Pointer to PROCESS_INFORMATION structure. */
if (!ok) {
DWORD err = GetLastError();
int chars = snprintf(msg, sizeof(msg) - 1,
"Tried to launch: \"%s\", but got error [%u]: ", cmdline, err);
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS|
FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars],
(300-chars), 0);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL);
return 2;
}
/*
* Close our references to the write handles that have now been inherited.
*/
CloseHandle(si.hStdOutput);
CloseHandle(si.hStdError);
WaitForInputIdle(pi.hProcess, 5000);
CloseHandle(pi.hThread);
/*
* Start the pipe reader threads.
*/
pipeThreads[0] = CreateThread(NULL, 0, ReadFromPipe, &Out, 0, &threadID);
pipeThreads[1] = CreateThread(NULL, 0, ReadFromPipe, &Err, 0, &threadID);
/*
* Block waiting for the process to end.
*/
WaitForSingleObject(pi.hProcess, INFINITE);
CloseHandle(pi.hProcess);
/*
* Wait for our pipe to get done reading, should it be a little slow.
*/
WaitForMultipleObjects(2, pipeThreads, TRUE, 500);
CloseHandle(pipeThreads[0]);
CloseHandle(pipeThreads[1]);
/*
* Look for the commandline warning code in both streams.
* - in MSVC 6 & 7 we get D4002, in MSVC 8 we get D9002.
*/
return !(strstr(Out.buffer, "D4002") != NULL
|| strstr(Err.buffer, "D4002") != NULL
|| strstr(Out.buffer, "D9002") != NULL
|| strstr(Err.buffer, "D9002") != NULL
|| strstr(Out.buffer, "D2021") != NULL
|| strstr(Err.buffer, "D2021") != NULL);
}
static int
CheckForLinkerFeature(
char **options,
int count)
{
STARTUPINFO si;
PROCESS_INFORMATION pi;
SECURITY_ATTRIBUTES sa;
DWORD threadID;
char msg[300];
BOOL ok;
HANDLE hProcess, h, pipeThreads[2];
int i;
char cmdline[255];
hProcess = GetCurrentProcess();
ZeroMemory(&pi, sizeof(PROCESS_INFORMATION));
ZeroMemory(&si, sizeof(STARTUPINFO));
si.cb = sizeof(STARTUPINFO);
si.dwFlags = STARTF_USESTDHANDLES;
si.hStdInput = INVALID_HANDLE_VALUE;
ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES));
sa.nLength = sizeof(SECURITY_ATTRIBUTES);
sa.lpSecurityDescriptor = NULL;
sa.bInheritHandle = TRUE;
/*
* Create a non-inheritible pipe.
*/
CreatePipe(&Out.pipe, &h, &sa, 0);
/*
* Dupe the write side, make it inheritible, and close the original.
*/
DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput, 0, TRUE,
DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
/*
* Same as above, but for the error side.
*/
CreatePipe(&Err.pipe, &h, &sa, 0);
DuplicateHandle(hProcess, h, hProcess, &si.hStdError, 0, TRUE,
DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
/*
* Base command line.
*/
lstrcpy(cmdline, "link.exe -nologo ");
/*
* Append our option for testing.
*/
for (i = 0; i < count; i++) {
lstrcat(cmdline, " \"");
lstrcat(cmdline, options[i]);
lstrcat(cmdline, "\"");
}
ok = CreateProcess(
NULL, /* Module name. */
cmdline, /* Command line. */
NULL, /* Process handle not inheritable. */
NULL, /* Thread handle not inheritable. */
TRUE, /* yes, inherit handles. */
DETACHED_PROCESS, /* No console for you. */
NULL, /* Use parent's environment block. */
NULL, /* Use parent's starting directory. */
&si, /* Pointer to STARTUPINFO structure. */
&pi); /* Pointer to PROCESS_INFORMATION structure. */
if (!ok) {
DWORD err = GetLastError();
int chars = snprintf(msg, sizeof(msg) - 1,
"Tried to launch: \"%s\", but got error [%u]: ", cmdline, err);
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS|
FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars],
(300-chars), 0);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL);
return 2;
}
/*
* Close our references to the write handles that have now been inherited.
*/
CloseHandle(si.hStdOutput);
CloseHandle(si.hStdError);
WaitForInputIdle(pi.hProcess, 5000);
CloseHandle(pi.hThread);
/*
* Start the pipe reader threads.
*/
pipeThreads[0] = CreateThread(NULL, 0, ReadFromPipe, &Out, 0, &threadID);
pipeThreads[1] = CreateThread(NULL, 0, ReadFromPipe, &Err, 0, &threadID);
/*
* Block waiting for the process to end.
*/
WaitForSingleObject(pi.hProcess, INFINITE);
CloseHandle(pi.hProcess);
/*
* Wait for our pipe to get done reading, should it be a little slow.
*/
WaitForMultipleObjects(2, pipeThreads, TRUE, 500);
CloseHandle(pipeThreads[0]);
CloseHandle(pipeThreads[1]);
/*
* Look for the commandline warning code in the stderr stream.
*/
return !(strstr(Out.buffer, "LNK1117") != NULL ||
strstr(Err.buffer, "LNK1117") != NULL ||
strstr(Out.buffer, "LNK4044") != NULL ||
strstr(Err.buffer, "LNK4044") != NULL ||
strstr(Out.buffer, "LNK4224") != NULL ||
strstr(Err.buffer, "LNK4224") != NULL);
}
static DWORD WINAPI
ReadFromPipe(
LPVOID args)
{
pipeinfo *pi = (pipeinfo *) args;
char *lastBuf = pi->buffer;
DWORD dwRead;
BOOL ok;
again:
if (lastBuf - pi->buffer + CHUNK > STATICBUFFERSIZE) {
CloseHandle(pi->pipe);
return (DWORD)-1;
}
ok = ReadFile(pi->pipe, lastBuf, CHUNK, &dwRead, 0L);
if (!ok || dwRead == 0) {
CloseHandle(pi->pipe);
return 0;
}
lastBuf += dwRead;
goto again;
return 0; /* makes the compiler happy */
}
static int
IsIn(
const char *string,
const char *substring)
{
return (strstr(string, substring) != NULL);
}
/*
* GetVersionFromFile --
* Looks for a match string in a file and then returns the version
* following the match where a version is anything acceptable to
* package provide or package ifneeded.
*/
static const char *
GetVersionFromFile(
const char *filename,
const char *match,
int numdots)
{
static char szBuffer[100];
char *szResult = NULL;
FILE *fp = fopen(filename, "rt");
if (fp != NULL) {
/*
* Read data until we see our match string.
*/
while (fgets(szBuffer, sizeof(szBuffer), fp) != NULL) {
LPSTR p, q;
p = strstr(szBuffer, match);
if (p != NULL) {
/*
* Skip to first digit after the match.
*/
p += strlen(match);
while (*p && !isdigit((unsigned char)*p)) {
++p;
}
/*
* Find ending whitespace.
*/
q = p;
while (*q && (strchr("0123456789.ab", *q)) && (((!strchr(".ab", *q)
&& !strchr("ab", q[-1])) || --numdots))) {
++q;
}
*q = 0;
szResult = p;
break;
}
}
fclose(fp);
}
return szResult;
}
/*
* List helpers for the SubstituteFile function
*/
typedef struct list_item_t {
struct list_item_t *nextPtr;
char * key;
char * value;
} list_item_t;
/* insert a list item into the list (list may be null) */
static list_item_t *
list_insert(list_item_t **listPtrPtr, const char *key, const char *value)
{
list_item_t *itemPtr = (list_item_t *)malloc(sizeof(list_item_t));
if (itemPtr) {
itemPtr->key = strdup(key);
itemPtr->value = strdup(value);
itemPtr->nextPtr = NULL;
while(*listPtrPtr) {
listPtrPtr = &(*listPtrPtr)->nextPtr;
}
*listPtrPtr = itemPtr;
}
return itemPtr;
}
static void
list_free(list_item_t **listPtrPtr)
{
list_item_t *tmpPtr, *listPtr = *listPtrPtr;
while (listPtr) {
tmpPtr = listPtr;
listPtr = listPtr->nextPtr;
free(tmpPtr->key);
free(tmpPtr->value);
free(tmpPtr);
}
}
/*
* SubstituteFile --
* As windows doesn't provide anything useful like sed and it's unreliable
* to use the tclsh you are building against (consider x-platform builds -
* eg compiling AMD64 target from IX86) we provide a simple substitution
* option here to handle autoconf style substitutions.
* The substitution file is whitespace and line delimited. The file should
* consist of lines matching the regular expression:
* \s*\S+\s+\S*$
*
* Usage is something like:
* nmakehlp -S << $** > $@
* @PACKAGE_NAME@ $(PACKAGE_NAME)
* @PACKAGE_VERSION@ $(PACKAGE_VERSION)
* <<
*/
static int
SubstituteFile(
const char *substitutions,
const char *filename)
{
static char szBuffer[1024], szCopy[1024];
list_item_t *substPtr = NULL;
FILE *fp, *sp;
fp = fopen(filename, "rt");
if (fp != NULL) {
/*
* Build a list of substutitions from the first filename
*/
sp = fopen(substitutions, "rt");
if (sp != NULL) {
while (fgets(szBuffer, sizeof(szBuffer), sp) != NULL) {
unsigned char *ks, *ke, *vs, *ve;
ks = (unsigned char*)szBuffer;
while (ks && *ks && isspace(*ks)) ++ks;
ke = ks;
while (ke && *ke && !isspace(*ke)) ++ke;
vs = ke;
while (vs && *vs && isspace(*vs)) ++vs;
ve = vs;
while (ve && *ve && !(*ve == '\r' || *ve == '\n')) ++ve;
*ke = 0, *ve = 0;
list_insert(&substPtr, (char*)ks, (char*)vs);
}
fclose(sp);
}
/* debug: dump the list */
#ifndef NDEBUG
{
int n = 0;
list_item_t *p = NULL;
for (p = substPtr; p != NULL; p = p->nextPtr, ++n) {
fprintf(stderr, "% 3d '%s' => '%s'\n", n, p->key, p->value);
}
}
#endif
/*
* Run the substitutions over each line of the input
*/
while (fgets(szBuffer, sizeof(szBuffer), fp) != NULL) {
list_item_t *p = NULL;
for (p = substPtr; p != NULL; p = p->nextPtr) {
char *m = strstr(szBuffer, p->key);
if (m) {
char *cp, *op, *sp;
cp = szCopy;
op = szBuffer;
while (op != m) *cp++ = *op++;
sp = p->value;
while (sp && *sp) *cp++ = *sp++;
op += strlen(p->key);
while (*op) *cp++ = *op++;
*cp = 0;
memcpy(szBuffer, szCopy, sizeof(szCopy));
}
}
printf("%s", szBuffer);
}
list_free(&substPtr);
}
fclose(fp);
return 0;
}
BOOL FileExists(LPCTSTR szPath)
{
#ifndef INVALID_FILE_ATTRIBUTES
#define INVALID_FILE_ATTRIBUTES ((DWORD)-1)
#endif
DWORD pathAttr = GetFileAttributes(szPath);
return (pathAttr != INVALID_FILE_ATTRIBUTES &&
!(pathAttr & FILE_ATTRIBUTE_DIRECTORY));
}
/*
* QualifyPath --
*
* This composes the current working directory with a provided path
* and returns the fully qualified and normalized path.
* Mostly needed to setup paths for testing.
*/
static int
QualifyPath(
const char *szPath)
{
char szCwd[MAX_PATH + 1];
GetFullPathName(szPath, sizeof(szCwd)-1, szCwd, NULL);
printf("%s\n", szCwd);
return 0;
}
/*
* Implements LocateDependency for a single directory. See that command
* for an explanation.
* Returns 0 if found after printing the directory.
* Returns 1 if not found but no errors.
* Returns 2 on any kind of error
* Basically, these are used as exit codes for the process.
*/
static int LocateDependencyHelper(const char *dir, const char *keypath)
{
HANDLE hSearch;
char path[MAX_PATH+1];
size_t dirlen;
int keylen, ret;
WIN32_FIND_DATA finfo;
if (dir == NULL || keypath == NULL)
return 2; /* Have no real error reporting mechanism into nmake */
dirlen = strlen(dir);
if ((dirlen + 3) > sizeof(path))
return 2;
strncpy(path, dir, dirlen);
strncpy(path+dirlen, "\\*", 3); /* Including terminating \0 */
keylen = strlen(keypath);
#if 0 /* This function is not available in Visual C++ 6 */
/*
* Use numerics 0 -> FindExInfoStandard,
* 1 -> FindExSearchLimitToDirectories,
* as these are not defined in Visual C++ 6
*/
hSearch = FindFirstFileEx(path, 0, &finfo, 1, NULL, 0);
#else
hSearch = FindFirstFile(path, &finfo);
#endif
if (hSearch == INVALID_HANDLE_VALUE)
return 1; /* Not found */
/* Loop through all subdirs checking if the keypath is under there */
ret = 1; /* Assume not found */
do {
int sublen;
/*
* We need to check it is a directory despite the
* FindExSearchLimitToDirectories in the above call. See SDK docs
*/
if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0)
continue;
sublen = strlen(finfo.cFileName);
if ((dirlen+1+sublen+1+keylen+1) > sizeof(path))
continue; /* Path does not fit, assume not matched */
strncpy(path+dirlen+1, finfo.cFileName, sublen);
path[dirlen+1+sublen] = '\\';
strncpy(path+dirlen+1+sublen+1, keypath, keylen+1);
if (FileExists(path)) {
/* Found a match, print to stdout */
path[dirlen+1+sublen] = '\0';
QualifyPath(path);
ret = 0;
break;
}
} while (FindNextFile(hSearch, &finfo));
FindClose(hSearch);
return ret;
}
/*
* LocateDependency --
*
* Locates a dependency for a package.
* keypath - a relative path within the package directory
* that is used to confirm it is the correct directory.
* The search path for the package directory is currently only
* the parent and grandparent of the current working directory.
* If found, the command prints
* name_DIRPATH=<full path of located directory>
* and returns 0. If not found, does not print anything and returns 1.
*/
static int LocateDependency(const char *keypath)
{
size_t i;
int ret;
static const char *paths[] = {"..", "..\\..", "..\\..\\.."};
for (i = 0; i < (sizeof(paths)/sizeof(paths[0])); ++i) {
ret = LocateDependencyHelper(paths[i], keypath);
if (ret == 0)
return ret;
}
return ret;
}
/*
* Local variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* indent-tabs-mode: t
* tab-width: 8
* End:
*/

6
pkgs/thread2.8.7/win/pkg.vc Normal file
View File

@@ -0,0 +1,6 @@
# remember to change configure.ac as well when these change
# (then re-autoconf)
PACKAGE_MAJOR = 2
PACKAGE_MINOR = 8
PACKAGE_VERSION = "2.8.7"

118
pkgs/thread2.8.7/win/rules-ext.vc Normal file
View File

@@ -0,0 +1,118 @@
# This file should only be included in makefiles for Tcl extensions,
# NOT in the makefile for Tcl itself.
!ifndef _RULES_EXT_VC
# We need to run from the directory the parent makefile is located in.
# nmake does not tell us what makefile was used to invoke it so parent
# makefile has to set the MAKEFILEVC macro or we just make a guess and
# warn if we think that is not the case.
!if "$(MAKEFILEVC)" == ""
!if exist("$(PROJECT).vc")
MAKEFILEVC = $(PROJECT).vc
!elseif exist("makefile.vc")
MAKEFILEVC = makefile.vc
!endif
!endif # "$(MAKEFILEVC)" == ""
!if !exist("$(MAKEFILEVC)")
MSG = ^
You must run nmake from the directory containing the project makefile.^
If you are doing that and getting this message, set the MAKEFILEVC^
macro to the name of the project makefile.
!message WARNING: $(MSG)
!endif
!if "$(PROJECT)" == "tcl"
!error The rules-ext.vc file is not intended for Tcl itself.
!endif
# We extract version numbers using the nmakehlp program. For now use
# the local copy of nmakehlp. Once we locate Tcl, we will use that
# one if it is newer.
!if [$(CC) -nologo -DNDEBUG "nmakehlp.c" -link -subsystem:console > nul]
!endif
# First locate the Tcl directory that we are working with.
!if "$(TCLDIR)" != ""
_RULESDIR = $(TCLDIR:/=\)
!else
# If an installation path is specified, that is also the Tcl directory.
# Also Tk never builds against an installed Tcl, it needs Tcl sources
!if defined(INSTALLDIR) && "$(PROJECT)" != "tk"
_RULESDIR=$(INSTALLDIR:/=\)
!else
# Locate Tcl sources
!if [echo _RULESDIR = \> nmakehlp.out] \
|| [nmakehlp -L generic\tcl.h >> nmakehlp.out]
_RULESDIR = ..\..\tcl
!else
!include nmakehlp.out
!endif
!endif # defined(INSTALLDIR)....
!endif # ifndef TCLDIR
# Now look for the targets.vc file under the Tcl root. Note we check this
# file and not rules.vc because the latter also exists on older systems.
!if exist("$(_RULESDIR)\lib\nmake\targets.vc") # Building against installed Tcl
_RULESDIR = $(_RULESDIR)\lib\nmake
!elseif exist("$(_RULESDIR)\win\targets.vc") # Building against Tcl sources
_RULESDIR = $(_RULESDIR)\win
!else
# If we have not located Tcl's targets file, most likely we are compiling
# against an older version of Tcl and so must use our own support files.
_RULESDIR = .
!endif
!if "$(_RULESDIR)" != "."
# Potentially using Tcl's support files. If this extension has its own
# nmake support files, need to compare the versions and pick newer.
!if exist("rules.vc") # The extension has its own copy
!if [echo TCL_RULES_MAJOR = \> versions.vc] \
&& [nmakehlp -V "$(_RULESDIR)\rules.vc" RULES_VERSION_MAJOR >> versions.vc]
!endif
!if [echo TCL_RULES_MINOR = \>> versions.vc] \
&& [nmakehlp -V "$(_RULESDIR)\rules.vc" RULES_VERSION_MINOR >> versions.vc]
!endif
!if [echo OUR_RULES_MAJOR = \>> versions.vc] \
&& [nmakehlp -V "rules.vc" RULES_VERSION_MAJOR >> versions.vc]
!endif
!if [echo OUR_RULES_MINOR = \>> versions.vc] \
&& [nmakehlp -V "rules.vc" RULES_VERSION_MINOR >> versions.vc]
!endif
!include versions.vc
# We have a newer version of the support files, use them
!if ($(TCL_RULES_MAJOR) != $(OUR_RULES_MAJOR)) || ($(TCL_RULES_MINOR) < $(OUR_RULES_MINOR))
_RULESDIR = .
!endif
!endif # if exist("rules.vc")
!endif # if $(_RULESDIR) != "."
# Let rules.vc know what copy of nmakehlp.c to use.
NMAKEHLPC = $(_RULESDIR)\nmakehlp.c
# Get rid of our internal defines before calling rules.vc
!undef TCL_RULES_MAJOR
!undef TCL_RULES_MINOR
!undef OUR_RULES_MAJOR
!undef OUR_RULES_MINOR
!if exist("$(_RULESDIR)\rules.vc")
!message *** Using $(_RULESDIR)\rules.vc
!include "$(_RULESDIR)\rules.vc"
!else
!error *** Could not locate rules.vc in $(_RULESDIR)
!endif
!endif # _RULES_EXT_VC

1869
pkgs/thread2.8.7/win/rules.vc Normal file
View File

File diff suppressed because it is too large Load Diff

98
pkgs/thread2.8.7/win/targets.vc Normal file
View File

@@ -0,0 +1,98 @@
#------------------------------------------------------------- -*- makefile -*-
# targets.vc --
#
# Part of the nmake based build system for Tcl and its extensions.
# This file defines some standard targets for the convenience of extensions
# and can be optionally included by the extension makefile.
# See TIP 477 (https://core.tcl-lang.org/tips/doc/main/tip/477.md) for docs.
$(PROJECT): setup pkgindex $(PRJLIB)
!ifdef PRJ_STUBOBJS
$(PROJECT): $(PRJSTUBLIB)
$(PRJSTUBLIB): $(PRJ_STUBOBJS)
$(LIBCMD) $**
$(PRJ_STUBOBJS):
$(CCSTUBSCMD) %s
!endif # PRJ_STUBOBJS
!ifdef PRJ_MANIFEST
$(PROJECT): $(PRJLIB).manifest
$(PRJLIB).manifest: $(PRJ_MANIFEST)
@nmakehlp -s << $** >$@
@MACHINE@ $(MACHINE:IX86=X86)
<<
!endif
!if "$(PROJECT)" != "tcl" && "$(PROJECT)" != "tk"
$(PRJLIB): $(PRJ_OBJS) $(RESFILE)
!if $(STATIC_BUILD)
$(LIBCMD) $**
!else
$(DLLCMD) $**
$(_VC_MANIFEST_EMBED_DLL)
!endif
-@del $*.exp
!endif
!if "$(PRJ_HEADERS)" != "" && "$(PRJ_OBJS)" != ""
$(PRJ_OBJS): $(PRJ_HEADERS)
!endif
# If parent makefile has defined stub objects, add their installation
# to the default install
!if "$(PRJ_STUBOBJS)" != ""
default-install: default-install-stubs
!endif
# Unlike the other default targets, these cannot be in rules.vc because
# the executed command depends on existence of macro PRJ_HEADERS_PUBLIC
# that the parent makefile will not define until after including rules-ext.vc
!if "$(PRJ_HEADERS_PUBLIC)" != ""
default-install: default-install-headers
default-install-headers:
@echo Installing headers to '$(INCLUDE_INSTALL_DIR)'
@for %f in ($(PRJ_HEADERS_PUBLIC)) do @$(COPY) %f "$(INCLUDE_INSTALL_DIR)"
!endif
!if "$(DISABLE_STANDARD_TARGETS)" == ""
DISABLE_STANDARD_TARGETS = 0
!endif
!if "$(DISABLE_TARGET_setup)" == ""
DISABLE_TARGET_setup = 0
!endif
!if "$(DISABLE_TARGET_install)" == ""
DISABLE_TARGET_install = 0
!endif
!if "$(DISABLE_TARGET_clean)" == ""
DISABLE_TARGET_clean = 0
!endif
!if "$(DISABLE_TARGET_test)" == ""
DISABLE_TARGET_test = 0
!endif
!if "$(DISABLE_TARGET_shell)" == ""
DISABLE_TARGET_shell = 0
!endif
!if !$(DISABLE_STANDARD_TARGETS)
!if !$(DISABLE_TARGET_setup)
setup: default-setup
!endif
!if !$(DISABLE_TARGET_install)
install: default-install
!endif
!if !$(DISABLE_TARGET_clean)
clean: default-clean
realclean: hose
hose: default-hose
distclean: realclean default-distclean
!endif
!if !$(DISABLE_TARGET_test)
test: default-test
!endif
!if !$(DISABLE_TARGET_shell)
shell: default-shell
!endif
!endif # DISABLE_STANDARD_TARGETS

57
pkgs/thread2.8.7/win/thread.rc Normal file
View File

@@ -0,0 +1,57 @@
// Version resource script
//
#include <winver.h>
#define RESOURCE_INCLUDED
LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */
#ifndef COMMAVERSION
#define COMMAVERSION PACKAGE_MAJOR,PACKAGE_MINOR,0,0
#endif
#ifndef DOTVERSION
#define DOTVERSION PACKAGE_VERSION
#endif
#ifndef PRJLIBNAME
#ifdef DEBUG
#define PRJLIBNAME "thread" STRINGIFY(JOIN(PACKAGE_MAJOR,PACKAGE_MINOR)) "d.dll\0"
#else
#define PRJLIBNAME "thread" STRINGIFY(JOIN(PACKAGE_MAJOR,PACKAGE_MINOR)) ".dll\0"
#endif
#endif
VS_VERSION_INFO VERSIONINFO
FILEVERSION COMMAVERSION
PRODUCTVERSION COMMAVERSION
FILEFLAGSMASK 0x3fL
#if DEBUG
FILEFLAGS 0x1L
#else
FILEFLAGS 0x0L
#endif
FILEOS VOS_NT_WINDOWS32
FILETYPE VFT_DLL
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
BEGIN
BLOCK "040904b0" /* LANG_ENGLISH/SUBLANG_ENGLISH_US, Unicode CP */
BEGIN
VALUE "FileDescription", "Threading extension library for Tcl"
VALUE "OriginalFilename", PRJLIBNAME
VALUE "CompanyName", "NONE! Open-sourced with no owner\0"
VALUE "FileVersion", DOTVERSION
VALUE "LegalCopyright", "Under BSD license\0"
VALUE "ProductName", "Tcl for Windows\0"
VALUE "ProductVersion", DOTVERSION
VALUE "Authors", "Brent Welch,\r\n" "Andreas Kupries, \r\n" "David Gravereaux,\r\n" "Zoran Vasiljevic" "\0"
END
END
BLOCK "VarFileInfo"
BEGIN
VALUE "Translation", 0x409, 1200
END
END

271
pkgs/thread2.8.7/win/thread_win.dsp Normal file
View File

@@ -0,0 +1,271 @@
# Microsoft Developer Studio Project File - Name="thread" - Package Owner=<4>
# Microsoft Developer Studio Generated Build File, Format Version 6.00
# ** DO NOT EDIT **
# TARGTYPE "Win32 (x86) External Target" 0x0106
CFG=thread - Win32 Debug
!MESSAGE This is not a valid makefile. To build this project using NMAKE,
!MESSAGE use the Export Makefile command and run
!MESSAGE
!MESSAGE NMAKE /f "thread_win.mak".
!MESSAGE
!MESSAGE You can specify a configuration when running NMAKE
!MESSAGE by defining the macro CFG on the command line. For example:
!MESSAGE
!MESSAGE NMAKE /f "thread_win.mak" CFG="thread - Win32 Debug"
!MESSAGE
!MESSAGE Possible choices for configuration are:
!MESSAGE
!MESSAGE "thread - Win32 Release" (based on "Win32 (x86) External Target")
!MESSAGE "thread - Win32 Debug" (based on "Win32 (x86) External Target")
!MESSAGE
# Begin Project
# PROP AllowPerConfigDependencies 0
# PROP Scc_ProjName ""
# PROP Scc_LocalPath ""
!IF "$(CFG)" == "thread - Win32 Release"
# PROP BASE Use_MFC 0
# PROP BASE Use_Debug_Libraries 0
# PROP BASE Output_Dir "Release"
# PROP BASE Intermediate_Dir "Release"
# PROP BASE Cmd_Line "NMAKE /f thread.mak"
# PROP BASE Rebuild_Opt "/a"
# PROP BASE Target_File "thread.exe"
# PROP BASE Bsc_Name "thread.bsc"
# PROP BASE Target_Dir ""
# PROP Use_MFC 0
# PROP Use_Debug_Libraries 0
# PROP Output_Dir "Release"
# PROP Intermediate_Dir "Release"
# PROP Cmd_Line "nmake -nologo -f makefile.vc TCLDIR=E:\tcl MSVCDIR=IDE"
# PROP Rebuild_Opt "-a"
# PROP Target_File "Release\thread27.dll"
# PROP Bsc_Name ""
# PROP Target_Dir ""
!ELSEIF "$(CFG)" == "thread - Win32 Debug"
# PROP BASE Use_MFC 0
# PROP BASE Use_Debug_Libraries 1
# PROP BASE Output_Dir "Debug"
# PROP BASE Intermediate_Dir "Debug"
# PROP BASE Cmd_Line "NMAKE /f thread.mak"
# PROP BASE Rebuild_Opt "/a"
# PROP BASE Target_File "thread.exe"
# PROP BASE Bsc_Name "thread.bsc"
# PROP BASE Target_Dir ""
# PROP Use_MFC 0
# PROP Use_Debug_Libraries 1
# PROP Output_Dir "Debug"
# PROP Intermediate_Dir "Debug"
# PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=symbols TCLDIR=E:\tcl MSVCDIR=IDE"
# PROP Rebuild_Opt "-a"
# PROP Target_File "Debug\thread27d.dll"
# PROP Bsc_Name ""
# PROP Target_Dir ""
!ENDIF
# Begin Target
# Name "thread - Win32 Release"
# Name "thread - Win32 Debug"
!IF "$(CFG)" == "thread - Win32 Release"
!ELSEIF "$(CFG)" == "thread - Win32 Debug"
!ENDIF
ROOT=..
# Begin Group "generic"
# PROP Default_Filter ""
# Begin Source File
SOURCE=$(ROOT)\generic\threadNs.c
# End Source File
# Begin Source File
SOURCE=$(ROOT)\generic\psGdbm.c
# End Source File
# Begin Source File
SOURCE=$(ROOT)\generic\psGdbm.h
# End Source File
# Begin Source File
SOURCE=$(ROOT)\generic\tclThread.h
# End Source File
# Begin Source File
SOURCE=$(ROOT)\generic\tclThreadInt.h
# End Source File
# Begin Source File
SOURCE=$(ROOT)\generic\tclXkeylist.c
# End Source File
# Begin Source File
SOURCE=$(ROOT)\generic\tclXkeylist.h
# End Source File
# Begin Source File
SOURCE=$(ROOT)\generic\threadCmd.c
# End Source File
# Begin Source File
SOURCE=$(ROOT)\generic\threadPoolCmd.c
# End Source File
# Begin Source File
SOURCE=$(ROOT)\generic\threadSpCmd.c
# End Source File
# Begin Source File
SOURCE=$(ROOT)\generic\threadSvCmd.c
# End Source File
# Begin Source File
SOURCE=$(ROOT)\generic\threadSvCmd.h
# End Source File
# Begin Source File
SOURCE=$(ROOT)\generic\threadSvKeylistCmd.c
# End Source File
# Begin Source File
SOURCE=$(ROOT)\generic\threadSvKeylistCmd.h
# End Source File
# Begin Source File
SOURCE=$(ROOT)\generic\threadSvListCmd.c
# End Source File
# Begin Source File
SOURCE=$(ROOT)\generic\threadSvListCmd.h
# End Source File
# End Group
# Begin Group "doc"
# PROP Default_Filter ""
# Begin Group "html"
# PROP Default_Filter ""
# Begin Source File
SOURCE=$(ROOT)\doc\html\thread.html
# End Source File
# Begin Source File
SOURCE=$(ROOT)\doc\html\tpool.html
# End Source File
# Begin Source File
SOURCE=$(ROOT)\doc\html\tsv.html
# End Source File
# Begin Source File
SOURCE=$(ROOT)\doc\html\ttrace.html
# End Source File
# End Group
# Begin Group "man"
# PROP Default_Filter ""
# Begin Source File
SOURCE=$(ROOT)\doc\man\thread.n
# End Source File
# Begin Source File
SOURCE=$(ROOT)\doc\man\tpool.n
# End Source File
# Begin Source File
SOURCE=$(ROOT)\doc\man\tsv.n
# End Source File
# Begin Source File
SOURCE=$(ROOT)\doc\man\ttrace.n
# End Source File
# End Group
# Begin Source File
SOURCE=$(ROOT)\doc\format.tcl
# End Source File
# Begin Source File
SOURCE=$(ROOT)\doc\man.macros
# End Source File
# Begin Source File
SOURCE=$(ROOT)\doc\thread.man
# End Source File
# Begin Source File
SOURCE=$(ROOT)\doc\tpool.man
# End Source File
# Begin Source File
SOURCE=$(ROOT)\doc\tsv.man
# End Source File
# Begin Source File
SOURCE=$(ROOT)\doc\ttrace.man
# End Source File
# End Group
# Begin Group "win"
# PROP Default_Filter ""
# Begin Group "vc"
# PROP Default_Filter ""
# Begin Source File
SOURCE=.\makefile.vc
# End Source File
# Begin Source File
SOURCE=.\nmakehlp.c
# End Source File
# Begin Source File
SOURCE=.\pkg.vc
# End Source File
# Begin Source File
SOURCE=.\README.vc.txt
# End Source File
# Begin Source File
SOURCE=.\rules.vc
# End Source File
# End Group
# Begin Source File
SOURCE=$(ROOT)\win\README.txt
# End Source File
# Begin Source File
SOURCE=$(ROOT)\win\thread.rc
# End Source File
# End Group
# Begin Source File
SOURCE=$(ROOT)\ChangeLog
# End Source File
# Begin Source File
SOURCE=$(ROOT)\license.terms
# End Source File
# Begin Source File
SOURCE=$(ROOT)\README
# End Source File
# End Target
# End Project

29
pkgs/thread2.8.7/win/thread_win.dsw Normal file
View File

@@ -0,0 +1,29 @@
Microsoft Developer Studio Workspace File, Format Version 6.00
# WARNING: DO NOT EDIT OR DELETE THIS WORKSPACE FILE!
###############################################################################
Project: "thread"=.\thread.dsp - Package Owner=<4>
Package=<5>
{{{
}}}
Package=<4>
{{{
}}}
###############################################################################
Global:
Package=<5>
{{{
}}}
Package=<3>
{{{
}}}
###############################################################################